[SCM] snd/master: Imported Upstream version 16.6
umlaeute at users.alioth.debian.org
umlaeute at users.alioth.debian.org
Mon Jun 27 19:59:58 UTC 2016
The following commit has been merged in the master branch:
commit 3eb3c4d013403119c639870bf55d61e3456c1078
Author: IOhannes m zmölnig <zmoelnig at umlautQ.umlaeute.mur.at>
Date: Mon Jun 27 21:22:00 2016 +0200
Imported Upstream version 16.6
diff --git a/COPYING b/COPYING
index c6e8611..ddcaecf 100644
--- a/COPYING
+++ b/COPYING
@@ -1,5 +1,5 @@
Snd is a sound editor written by Bill Schottstaedt (bil at ccrma.stanford.edu).
-Except where otherwise noted, it is Copyright 1996-2013 Bill Schottstaedt.
+Except where otherwise noted, it is Copyright 1996-2016 Bill Schottstaedt.
diff --git a/HISTORY.Snd b/HISTORY.Snd
index 046780c..65dc385 100644
--- a/HISTORY.Snd
+++ b/HISTORY.Snd
@@ -1,5 +1,7 @@
Snd change log
+ 14-Jun: Snd 16.6.
+ 30-May: snd-lint.scm, symbol takes any number of args.
6-May: Snd 16.5.
29-Mar: --with-webserver configuration (Kjetil Matheussen)
28-Mar: Snd 16.4.
diff --git a/NEWS b/NEWS
index bd5c9ce..1e813d7 100644
--- a/NEWS
+++ b/NEWS
@@ -1,14 +1,11 @@
-Snd 16.5
+Snd 16.6.
-Kjetil Matheussen added the --with-webserver configuration flag to Snd, and
- made all the supporting changes.
+added snd-lint.scm (Snd extensions for lint)
-Daniel Hensel sent instructions to build Snd in OSX -- see README.Snd.
+s7's symbol function now takes any number of string args
+ these are all concatenated to form the new symbol name
+s7's make-vector no longer takes an optional fourth argument.
-ttaenc removed: it appears to be dead (no movement in 10 years), or infected.
+checked: gtk 3.21.2, sbcl 1.3.6, Fedora 24
-changed spectr.scm to export only *spectr*, rgb.scm *rgb*.
-
-checked: sbcl 1.3.4|5, gtk 3.20.2|3 3.21.1, gsl 2.1
-
-Thanks!: Greg Santucci, Daniel Lopez, Kjetil Matheussen, Daniel Hensel
+Thanks!: Joe Python, Tito Latini.
\ No newline at end of file
diff --git a/analog-filter.scm b/analog-filter.scm
index ae71184..33a5ef5 100644
--- a/analog-filter.scm
+++ b/analog-filter.scm
@@ -73,22 +73,24 @@
(set! b (cons (float-vector 1.0 (c k) (c (+ k 1))) b)))))
-(define (prototype->highpass n num den)
- (do ((g 1.0)
- (numt (make-float-vector (length num)))
- (dent (make-float-vector (length den)))
- (k 0 (+ k 2))
- (i 0 (+ i 3)))
- ((>= k n)
- (set! (numt 0) g)
- (list numt dent))
- (set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
- (set! (numt i ) 1.0)
- (set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
- (set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
- (set! (dent i ) 1.0)
- (set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
- (set! (dent (+ i 2)) (/ (den i) (den (+ i 2))))))
+(define (prototype->highpass n proto)
+ (let ((num (car proto))
+ (den (cadr proto)))
+ (do ((g 1.0)
+ (numt (make-float-vector (length num)))
+ (dent (make-float-vector (length den)))
+ (k 0 (+ k 2))
+ (i 0 (+ i 3)))
+ ((>= k n)
+ (set! (numt 0) g)
+ (list numt dent))
+ (set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
+ (set! (numt i ) 1.0)
+ (set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
+ (set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
+ (set! (dent i ) 1.0)
+ (set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
+ (set! (dent (+ i 2)) (/ (den i) (den (+ i 2)))))))
;;; ---------------- Butterworth ----------------
@@ -124,7 +126,7 @@ freq (srate = 1.0): (make-butterworth-highpass 8 .1)"))
(lambda (n fc)
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (butterworth-prototype n))
- (hproto (prototype->highpass n (car proto) (cadr proto)))
+ (hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
@@ -188,7 +190,7 @@ fc = cutoff freq (srate = 1.0): (make-chebyshev-highpass 8 .1 .01)"))
(lambda* (n fc (ripple 1.0))
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (chebyshev-prototype n ripple))
- (hproto (prototype->highpass n (car proto) (cadr proto)))
+ (hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
@@ -253,7 +255,7 @@ fc = cutoff freq (srate = 1.0): (make-inverse-chebyshev-highpass 10 .1 120)"))
(lambda* (n fc (loss-dB 60.0))
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (inverse-chebyshev-prototype n loss-dB))
- (hproto (prototype->highpass n (car proto) (cadr proto)))
+ (hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
@@ -342,7 +344,7 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(lambda* (n fc)
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (bessel-prototype n))
- (hproto (prototype->highpass n (car proto) (cadr proto)))
+ (hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
@@ -431,9 +433,7 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(set! (num j ) 1.0)
(set! (num (+ j 1)) (* -2.0 (real-part z)))
(set! (num (+ j 2)) pz))))
- (let* ((optarg0 (* k1p k1p))
- (optarg1 (/ 1.0 e))
- (minf (minimize-function findv 0.0 (/ 1.0 e) optarg0 optarg1))
+ (let* ((minf (minimize-function findv 0.0 (/ 1.0 e) (* k1p k1p) (/ 1.0 e)))
(v0 (/ (* k minf)
(* n (gsl-ellipk (* k k1)))))
(vals (gsl-ellipj v0 (- 1.0 m)))
@@ -470,7 +470,7 @@ fc = cutoff freq (srate = 1.0): (make-elliptic-highpass 8 .25 .01 90)"))
(lambda* (n fc (ripple 1.0) (loss-dB 60.0))
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (elliptic-prototype n ripple loss-dB))
- (hproto (prototype->highpass n (car proto) (cadr proto)))
+ (hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
diff --git a/animals.scm b/animals.scm
index bcbf665..d76a69f 100644
--- a/animals.scm
+++ b/animals.scm
@@ -1437,7 +1437,7 @@
;; rocky 31 1
;; (an experiment with wave-train in place of pulsed env)
(let* ((wave-len 256)
- (pulse (let ((v (make-float-vector wave-len 0.0))
+ (pulse (let ((v (make-float-vector wave-len))
(pulse-ampf (make-env '(0.000 0.000 0.063 0.312 0.277 0.937 0.405 1.000 0.617 0.696 0.929 0.146 2.000 0.000) :length wave-len)))
(do ((i 0 (+ i 1)))
((= i wave-len))
@@ -1852,7 +1852,7 @@
(pulse-samps (seconds->samples pulse-dur))
(pulse-sep (seconds->samples pulse-dur))
(pulses 0)
- (obank (make-oscil-bank freqs (make-float-vector 7 0.0) amps #t)))
+ (obank (make-oscil-bank freqs (make-float-vector 7) amps #t)))
(do ((i start (+ i pulse-sep)))
((>= i stop))
(let ((pulse-stop (+ i pulse-samps)))
@@ -2960,7 +2960,7 @@
(do ((i 0 (+ i 1)))
((= i 40))
(savannah-2 (+ beg 1.29 .36 (* i .0145)) (* amp af) 5600)
- (set! af (if (< i 20) (+ af .004) (- af .004)))))
+ (set! af ((if (< i 20) + -) af 0.004))))
(savannah-7 (+ beg 2.27) (* .4 amp))
@@ -3625,7 +3625,7 @@
(initial-ampf (make-env '(0 0 1 1 10 1 11 0) :duration initial-dur :scaler (* amp initial-amp)))
(initial-gen (make-oscil initial-pitch))
- (buzz-frq-table (let ((v (make-float-vector buzz-size 0.0))
+ (buzz-frq-table (let ((v (make-float-vector buzz-size))
(bfrqf (make-env (vector 0 (if gliss-up
(values buzz-low .5 buzz-mid 1 buzz-high)
(values buzz-high .5 buzz-mid 1 buzz-low)))
@@ -3635,7 +3635,7 @@
((= i buzz-size))
(set! (v i) (env bfrqf)))
v))
- (buzz-amp-table (let ((v (make-float-vector buzz-size 0.0))
+ (buzz-amp-table (let ((v (make-float-vector buzz-size))
(bampf (make-env (if gliss-up
'(0 0 1 1 2.5 .7 3 0 3.5 0)
'(0 0 .5 1 2 1 3 0 3.5 0))
@@ -3985,8 +3985,8 @@
(stop (seconds->samples (+ beg dur)))
(ampf (make-env '(0.000 0.000 0.052 0.100 0.130 0.538 0.261 0.845 0.438 0.983 0.580 0.917 0.738 0.720 0.860 0.475 0.941 0.172 1.000 0.000)
:duration dur :scaler (/ amp 2.25)))
- (gen1 (make-rxyk!cos 3360 (/ -200 3360) 0.7))
- (gen2 (make-rxyk!cos 3760 (/ 200 3760) 0.3))
+ (gen1 (make-rxyk!cos 3360 -5/84 0.7)) ; (/ 200 3360)
+ (gen2 (make-rxyk!cos 3760 5/94 0.3)) ; (/ 200 3760)
(gen3 (make-polywave 3660 (list 1 (* .25 .98) 2 (* .25 .02))))
(frqf (make-env '(0 1 .1 0 .95 0 1.0 -.1) :duration dur :scaler (hz->radians 10.0)))
(rnd (make-rand-interp 100 (hz->radians 3))))
@@ -4125,7 +4125,7 @@
0.794 0.510 0.831 0.510 0.909 0.494 1.000 0.499)
:duration bump-dur :offset -0.5)))
- (let ((bump-wave (make-float-vector bump-samps 0.0)))
+ (let ((bump-wave (make-float-vector bump-samps)))
(do ((i 0 (+ i 1)))
((= i bump-samps))
(set! (bump-wave i) (env bump)))
@@ -4288,14 +4288,14 @@
;;; American crow
(define (nrcos->polywave n r scl)
- (if (< 0 n 8192)
+ (if (not (< 0 n 8192))
+ (error 'out-of-range "nrcos->polywave: too many partials")
(let ((lst ())
(total (polynomial (make-float-vector n 1.0) r)))
(set! scl (/ scl total))
(do ((i 0 (+ i 1)))
((= i n) (reverse lst))
- (set! lst (cons (* scl (expt r i)) (cons (+ i 1) lst)))))
- (error 'out-of-range "nrcos->polywave: too many partials")))
+ (set! lst (cons (* scl (expt r i)) (cons (+ i 1) lst)))))))
(defanimal (american-crow beg amp)
(let ((dur 0.27))
@@ -7280,9 +7280,9 @@
(set! (ampfs 4) (make-env '(0.000 0.000 0.159 0.995 0.314 0.997 0.598 0.000 1.000 0.000)
:duration dur :scaler .01))
- (let ((frqs (make-float-vector 5 0.0))
- (amps (make-float-vector 5 0.0)))
- (let ((obank (make-oscil-bank frqs (make-float-vector 5 0.0) amps)))
+ (let ((frqs (make-float-vector 5))
+ (amps (make-float-vector 5)))
+ (let ((obank (make-oscil-bank frqs (make-float-vector 5) amps)))
(do ((i start (+ i 1)))
((= i stop))
(let ((frq (env frqf)))
diff --git a/bess.scm b/bess.scm
index 7c6e5b3..6cc66c3 100644
--- a/bess.scm
+++ b/bess.scm
@@ -40,8 +40,7 @@
(XtVaSetValues label (list XmNlabelString s1))
(XmStringFree s1)))
- (let* ((light-blue *position-color*)
- (form (XtCreateManagedWidget "form" xmFormWidgetClass shell
+ (let* ((form (XtCreateManagedWidget "form" xmFormWidgetClass shell
(list XmNbackground white
XmNforeground black
XmNresizePolicy XmRESIZE_GROW)))
@@ -78,7 +77,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
+ XmNbackground *position-color*)))
;; amp
(amp (XtCreateManagedWidget "amp:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
@@ -105,7 +104,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
+ XmNbackground *position-color*)))
;; fm index
(fm-index (XtCreateManagedWidget "fm index:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
@@ -132,7 +131,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
+ XmNbackground *position-color*)))
;; c/m ratio
(cm-ratio (XtCreateManagedWidget "c/m ratio:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
@@ -159,7 +158,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
- XmNbackground light-blue)))
+ XmNbackground *position-color*)))
(frequency 220.0)
(low-frequency 40.0)
(high-frequency 2000.0)
@@ -221,7 +220,7 @@
(let* ((bufsize 256)
(srate 22050)
(work-proc #f)
- ;(data (make-float-vector bufsize 0.0))
+ ;(data (make-float-vector bufsize))
(port (mus-audio-open-output mus-audio-default srate 1 mus-lshort (* bufsize 2))))
(if (< port 0)
(format () "can't open DAC!"))
@@ -239,7 +238,7 @@
(XtUnmanageChild shell)))
(set! work-proc (XtAppAddWorkProc app
(lambda (ignored-arg)
- (let ((data (make-float-vector bufsize 0.0)))
+ (let ((data (make-float-vector bufsize)))
(do ((i 0 (+ 1 i)))
((= i bufsize))
(float-vector-set! data i (* amplitude playing
diff --git a/bess1.scm b/bess1.scm
index 98fc8e9..570172a 100644
--- a/bess1.scm
+++ b/bess1.scm
@@ -51,7 +51,7 @@
(do ((i 0 (+ i 1)))
((= i *clm-rt-bufsize*))
(set! (data i) (func)))
- (mus-audio-write *output* (copy data (make-float-vector (list 1 *clm-rt-bufsize*) 0.0)) *clm-rt-bufsize*)
+ (mus-audio-write *output* (copy data (make-float-vector (list 1 *clm-rt-bufsize*))) *clm-rt-bufsize*)
#f)
(begin
(mus-audio-close *output*)
@@ -118,24 +118,21 @@
(if (> (random 1.0) 0.5) (set! cellsiz (+ 1 cellsiz)))
(set! cellctr cellbeg)))
- (format () "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
- dur
- (let ((freq (* cfreq 16.351 16
- (expt 2 (/ (vmode (vpits cellctr))
- 12.0)))))
+ (let ((freq (* cfreq 16.351 16
+ (expt 2 (/ (vmode (vpits cellctr)) 12.0)))))
+ (format () "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
+ dur
(if (< (* 8 freq) *clm-srate*)
freq
- (/ freq 4)))
- (* camp 0.3) cindex)
+ (/ freq 4))
+ (* camp 0.3)
+ cindex)
- (set! func (make-rt-violin dur
- (let ((freq (* cfreq 16.351 16
- (expt 2 (/ (vmode (vpits cellctr))
- 12.0)))))
+ (set! func (make-rt-violin dur
(if (< (* 8 freq) *clm-srate*)
freq
- (/ freq 4)))
- (* camp 0.3) :fm-index cindex))
+ (/ freq 4))
+ (* camp 0.3) :fm-index cindex)))
(set! len (ceiling (/ (seconds->samples dur) bufsize)))))
func)))
@@ -262,8 +259,7 @@
(app (cadr shell-app))
(shell (car shell-app))
(dpy (XtDisplay shell))
- (screen (DefaultScreenOfDisplay dpy))
- (black (BlackPixelOfScreen screen)))
+ (black (BlackPixelOfScreen (DefaultScreenOfDisplay dpy))))
(define (get-color color)
(let ((col (XColor))
diff --git a/binary-io.scm b/binary-io.scm
index b5ce723..30341f2 100644
--- a/binary-io.scm
+++ b/binary-io.scm
@@ -25,7 +25,7 @@
;;; -------- strings (unterminated)
-(define (read-chars len)
+(define* (read-chars (len 4))
(let ((str (make-string len)))
(do ((i 0 (+ i 1)))
((= i len) str)
@@ -239,16 +239,15 @@
(define (read-au-header file)
(with-input-from-file file
(lambda ()
- (let ((magic (read-chars 4)))
+ (let ((magic (read-chars)))
(if (not (string=? magic ".snd"))
(error 'bad-header "~A is not an au file: ~A" file)
(let* ((data-location (read-bint32))
(data-size (read-bint32))
(sample-type (read-bint32))
(srate (read-bint32))
- (chns (read-bint32))
- (comment (io-read-string)))
- (list magic data-location data-size sample-type srate chns comment)))))))
+ (chns (read-bint32)))
+ (list magic data-location data-size sample-type srate chns (io-read-string)))))))) ; io-read-string = comment
(define (write-au-header file chns srate data-size sample-type comment) ; data-size in bytes
;; common sample-types: 1 mulaw, 2 linear_8, 3 linear_16, 4 linear_24, 5 linear_32, 6 float, 5 double, 27 alaw
@@ -277,11 +276,11 @@
(current-location 0))
(with-input-from-file file
(lambda ()
- (let ((magic (read-chars 4)))
+ (let ((magic (read-chars)))
(if (not (string=? magic "FORM"))
(error 'bad-header "~A is not an aif file: ~A" file magic)
(let (;(size (read-bint32))
- (magic (read-chars 4)))
+ (magic (read-chars)))
(set! current-location 12)
(if (not (member magic '("AIFF" "AIFC") string=?))
(error 'bad-header "~A is not an aif file: ~A" file magic)
@@ -289,7 +288,7 @@
(call-with-exit
(lambda (return)
(let loop ()
- (let ((chunk (read-chars 4))
+ (let ((chunk (read-chars))
(chunk-size (read-bint32)))
(if (odd? chunk-size) (set! chunk-size (+ chunk-size 1)))
(if (string=? chunk "SSND")
diff --git a/bird.scm b/bird.scm
index 52128f5..4b8fcd7 100644
--- a/bird.scm
+++ b/bird.scm
@@ -37,27 +37,26 @@
(outa i (* (env amp-env)
(oscil os (env gls-env)))))))
-(define main-amp '(.00 .00 .25 1.00 .60 .70 .75 1.00 1.00 .0))
-(define bird-tap '(.00 .00 .01 1.00 .99 1.00 1.00 .0))
-(define bird-amp '(.00 .00 .25 1.00 .75 1.00 1.00 .0))
+(define main-amp '(0.0 0.0 .25 1.0 .60 .70 .75 1.0 1.0 .0))
+(define bird-tap '(0.0 0.0 .01 1.0 .99 1.0 1.0 .0))
+(define bird-amp '(0.0 0.0 .25 1.0 .75 1.0 1.0 .0))
(define b-orchard-oriole
(let ((documentation "(orchard-oriole beg) produces an orchard oriole call at time 'beg'"))
(lambda (beg)
- (let ((oriup '(.00 .00 1.00 1.0))
- (oridwn '(.00 1.00 1.00 .0))
- (oriupdwna '(.00 .00 .60 1.00 1.00 .60 ))
- (oriupdwnb '(.00 .50 .30 1.00 1.00 .0))
- (orimid '(.00 1.00 .05 .50 .10 1.00 .25 .00 .85 .50 1.00 .0))
- (oridwnup '(.00 .30 .25 .00 1.00 1.0))
- (oriamp '(.00 .00 .10 1.00 1.00 .0)))
+ (let ((oriup '(0.0 0.0 1.0 1.0))
+ (oridwn '(0.0 1.0 1.0 .0))
+ (oriupdwna '(0.0 0.0 .60 1.0 1.0 .60 ))
+ (oriupdwnb '(0.0 .50 .30 1.0 1.0 .0))
+ (orimid '(0.0 1.0 .05 .50 .10 1.0 .25 0.0 .85 .50 1.0 .0))
+ (oridwnup '(0.0 .30 .25 0.0 1.0 1.0))
+ (oriamp '(0.0 0.0 .10 1.0 1.0 .0)))
(set! beg (- beg .38))
(bird (+ beg .38) .03 3700 100 .05 oridwn main-amp)
(bird (+ beg .41) .05 2500 1000 .1 oriup main-amp)
(bigbird (+ beg .5) .1 2000 800 .2 oriupdwna main-amp '(1 1 2 .02 3 .05))
(bird (+ beg .65) .03 3900 1200 .1 oridwn main-amp)
- (let ((oribiga '(.00 .90 .15 1.00 .40 .30 .60 .60 .85 .00 1.00 .0)))
- (bigbird (+ beg .7) .21 2000 1200 .15 oribiga main-amp '(1 1 2 .05)))
+ (bigbird (+ beg .7) .21 2000 1200 .15 '(0.0 .90 .15 1.0 .40 .30 .60 .60 .85 0.0 1.0 .0) main-amp '(1 1 2 .05))
(bird (+ beg 1.0) .05 4200 1000 .1 oridwn main-amp)
(bigbird (+ beg 1.1) .1 2000 1000 .25 orimid main-amp '(1 1 2 .05))
(bigbird (+ beg 1.3) .1 2000 1000 .25 orimid main-amp '(1 1 2 .05))
@@ -74,8 +73,8 @@
(define b-cassins-kingbird
(let ((documentation "(cassins-kingbird beg) produces a cassins kingbird call at time 'beg'"))
(lambda (beg)
- (let ((kingfirst '(.00 .30 .45 1.00 .90 .10 1.00 .0))
- (kingsecond '(.00 .00 .02 .50 .04 .00 .06 .55 .08 .05 .10 .60 .12 .05 .14 .65 .16 .10 .18 .70 .20 .10 .22 .75 .24 .15 .26 .80 .28 .20 .30 .85 .32 .25 .34 .90 .36 .30 .38 .95 .40 .40 .42 1.00 .44 .50 .46 1.00 .48 .45 .50 1.00 .52 .50 .54 1.00 .56 .40 .58 .95 .60 .40 .62 .90 .64 .40 .66 .85 .68 .35 .70 .80 .72 .30 .74 .75 .76 .25 .78 .70 .80 .20 .82 .65 .84 .10 .86 .60 .88 .00 .90 .55 .92 .00 .94 .50 .96 .00 1.00 .40 )))
+ (let ((kingfirst '(0.0 .30 .45 1.0 .90 .10 1.0 .0))
+ (kingsecond '(0.0 0.0 .02 .50 .04 0.0 .06 .55 .08 .05 .10 .60 .12 .05 .14 .65 .16 .10 .18 .70 .20 .10 .22 .75 .24 .15 .26 .80 .28 .20 .30 .85 .32 .25 .34 .90 .36 .30 .38 .95 .40 .40 .42 1.0 .44 .50 .46 1.0 .48 .45 .50 1.0 .52 .50 .54 1.0 .56 .40 .58 .95 .60 .40 .62 .90 .64 .40 .66 .85 .68 .35 .70 .80 .72 .30 .74 .75 .76 .25 .78 .70 .80 .20 .82 .65 .84 .10 .86 .60 .88 0.0 .90 .55 .92 0.0 .94 .50 .96 0.0 1.0 .40 )))
(set! beg (- beg .03))
(bigbird (+ beg .03) .04 1700 1200 .15 kingfirst main-amp '(1 1 2 .5 3 0 4 .2))
(bigbird (+ beg .12) .18 1700 900 .25 kingsecond main-amp '(1 1 2 .01 3 0 4 .1))))))
@@ -84,7 +83,7 @@
(define b-chipping-sparrow
(let ((documentation "(chipping-sparrow beg) produces a chipping sparrow call at time 'beg'"))
(lambda (beg)
- (let ((chip-up '(.00 .80 .15 1.00 .75 .30 1.00 .0)))
+ (let ((chip-up '(0.0 .80 .15 1.0 .75 .30 1.0 .0)))
(bird beg .05 4000 2400 .2 chip-up main-amp)
(bird (+ beg .06) .05 4000 2400 .2 chip-up main-amp)
(bird (+ beg .12) .05 4000 2400 .2 chip-up main-amp)
@@ -107,8 +106,8 @@
(define b-bobwhite
(let ((documentation "(bobwhite beg) produces a bobwhite call at time 'beg'"))
(lambda (beg)
- (let ((bobup1 '(.00 .00 .40 1.00 1.00 1.0))
- (bobup2 '(.00 .00 .65 .50 1.00 1.0)))
+ (let ((bobup1 '(0.0 0.0 .40 1.0 1.0 1.0))
+ (bobup2 '(0.0 0.0 .65 .50 1.0 1.0)))
(set! beg (- beg .4))
(bigbird (+ beg .4) .2 1800 200 .1 bobup1 main-amp '(1 1 2 .02))
(bigbird (+ beg 1) .20 1800 1200 .2 bobup2 main-amp '(1 1 2 .02))))))
@@ -117,11 +116,10 @@
(define b-western-meadowlark
(let ((documentation "(western-meadowlark beg) produces a western meadowlark call at time 'beg'"))
(lambda (beg)
- (let ((down-skw '(.00 1.00 .40 .40 1.00 .0))
- (fas-down '(.00 1.00 1.00 .0)))
+ (let ((down-skw '(0.0 1.0 .40 .40 1.0 .0))
+ (fas-down '(0.0 1.0 1.0 .0)))
(set! beg (- beg .8))
- (let ((no-skw '(.00 .00 1.00 .0)))
- (bigbird (+ beg .800) .1 2010.000 0.000 .100 no-skw main-amp '(1 1 2 .04)))
+ (bigbird (+ beg 0.8) 0.1 2010.0 0.0 0.1 '(0.0 0.0 1.0 0.0) main-amp '(1 1 2 0.04))
(bigbird (+ beg 1.100) .15 3000.000 100.000 .110 down-skw main-amp '(1 1 2 .04))
(bigbird (+ beg 1.300) .25 2000.000 150.000 .200 down-skw main-amp '(1 1 2 .04))
(bigbird (+ beg 1.650) .15 3010.000 250.000 .110 down-skw main-amp '(1 1 2 .04))
@@ -134,15 +132,14 @@
(define b-scissor-tailed-flycatcher
(let ((documentation "(scissor-tailed-flycatcher beg) produces a scissor-tailed flycatcher call at time 'beg'"))
(lambda (beg)
- (let ((scissor '(.00 .00 .40 1.00 .60 1.00 1.00 .0)))
- (bigbird beg .05 1800 1800 .2 scissor main-amp '(1 .5 2 1 3 .5 4 .1 5 .01))))))
+ (bigbird beg .05 1800 1800 .2 '(0.0 0.0 .40 1.0 .60 1.0 1.0 .0) main-amp '(1 .5 2 1 3 .5 4 .1 5 .01)))))
(define b-great-horned-owl
(let ((documentation "(great-horned-owl beg) produces a great horned owl call at time 'beg'"))
(lambda (beg)
- (let ((owlup '(.00 .00 .30 1.00 1.00 1.0))
- (owldown '(.00 1.00 1.00 .0)))
+ (let ((owlup '(0.0 0.0 .30 1.0 1.0 1.0))
+ (owldown '(0.0 1.0 1.0 .0)))
(set! beg (- beg .3))
(bigbird (+ beg .3) .1 300 0 .1 main-amp main-amp '(1 1 3 .02 7 .01))
(bigbird (+ beg .6) .4 293 6 .1 owldown main-amp '(1 1 3 .02 7 .01))
@@ -153,10 +150,10 @@
(define b-black-throated-gray-warbler
(let ((documentation "(black-throated-gray-warbler beg) produces a black throated gray warbler call at time 'beg'"))
(lambda (beg)
- (let ((grayone '(.00 .50 .02 .60 .04 .45 .06 .62 .08 .40 .10 .65 .12 .35 .14 .70 .18 .30 .20 .70 .22 .30 .24 .70 .25 .20 .30 .80 .35 .10 .40 .90 .45 .00 .50 1.00 .55 .00 .60 1.00 .65 .00 .70 1.00 .75 .00 .80 1.00 .85 .00 .90 1.00 .95 .00 1.00 .50 ))
- (graytwo '(.00 .00 .01 .40 .02 .00 .03 .40 .04 .00 .05 .40 .06 .00 .07 .40 .08 .00 .09 .40 .10 .00 .25 .80 .40 .30 .55 1.00 .70 .00 .85 .80 1.00 .40 ))
- (graythree '(.00 1.00 .01 .60 .02 1.00 .03 .60 .04 1.00 .05 .60 .06 1.00 .07 .60 .08 1.00 .09 .60 .10 1.00 .11 .60 .12 1.00 .13 .60 .14 1.00 .15 .60 .16 1.00 .17 .60 .18 1.00 .19 .60 .20 1.00 .21 .55 .22 1.00 .23 .50 .24 1.00 .25 .50 .26 1.00 .27 .50 .28 1.00 .29 .50 .30 1.00 .31 .50 .32 1.00 .33 .50 .34 1.00 .35 .50 .36 1.00 .37 .50 .38 1.00 .39 .50 .40 1.00 .41 .50 .42 1.00 .43 .50 .44 1.00 .45 .50 .46 1.00 .47 .50 .48 1.00 .49 .50 .50 1.00 .51 .50 .52 1.00 .53 .50 .54 1.00 .55 .50 .56 1.00 .57 .50 .58 1.00 .59 .50 .60 1.00 1.00 .0))
- (grayfour '(.00 .00 1.00 1.0)))
+ (let ((grayone '(0.0 .50 .02 .60 .04 .45 .06 .62 .08 .40 .10 .65 .12 .35 .14 .70 .18 .30 .20 .70 .22 .30 .24 .70 .25 .20 .30 .80 .35 .10 .40 .90 .45 0.0 .50 1.0 .55 0.0 .60 1.0 .65 0.0 .70 1.0 .75 0.0 .80 1.0 .85 0.0 .90 1.0 .95 0.0 1.0 .50 ))
+ (graytwo '(0.0 0.0 .01 .40 .02 0.0 .03 .40 .04 0.0 .05 .40 .06 0.0 .07 .40 .08 0.0 .09 .40 .10 0.0 .25 .80 .40 .30 .55 1.0 .70 0.0 .85 .80 1.0 .40 ))
+ (graythree '(0.0 1.0 .01 .60 .02 1.0 .03 .60 .04 1.0 .05 .60 .06 1.0 .07 .60 .08 1.0 .09 .60 .10 1.0 .11 .60 .12 1.0 .13 .60 .14 1.0 .15 .60 .16 1.0 .17 .60 .18 1.0 .19 .60 .20 1.0 .21 .55 .22 1.0 .23 .50 .24 1.0 .25 .50 .26 1.0 .27 .50 .28 1.0 .29 .50 .30 1.0 .31 .50 .32 1.0 .33 .50 .34 1.0 .35 .50 .36 1.0 .37 .50 .38 1.0 .39 .50 .40 1.0 .41 .50 .42 1.0 .43 .50 .44 1.0 .45 .50 .46 1.0 .47 .50 .48 1.0 .49 .50 .50 1.0 .51 .50 .52 1.0 .53 .50 .54 1.0 .55 .50 .56 1.0 .57 .50 .58 1.0 .59 .50 .60 1.0 1.0 .0))
+ (grayfour '(0.0 0.0 1.0 1.0)))
(bird beg .12 3700 600 .05 grayone main-amp)
(bird (+ beg .18) .08 3000 800 .07 graytwo main-amp)
(bird (+ beg .28) .12 3700 600 .12 grayone main-amp)
@@ -173,12 +170,11 @@
(define b-yellow-warbler
(let ((documentation "(yellow-warbler beg) produces a yellow warbler call at time 'beg'"))
(lambda (beg)
- (let ((yellow-swirl '(.00 1.00 .05 1.00 .60 .00 .80 .30 1.00 .10 ))
- (yellow-down '(.00 1.00 1.00 .0))
- (yellow-last '(.00 .00 .30 .20 .80 .70 1.00 1.0))
- (swirl-amp '(.00 .00 .90 1.00 1.00 .0)))
- (let ((yellow-up '(.00 .00 .60 1.00 1.00 .50 )))
- (bird beg .05 5600 400 .05 yellow-up main-amp))
+ (let ((yellow-swirl '(0.0 1.0 .05 1.0 .60 0.0 .80 .30 1.0 .10 ))
+ (yellow-down '(0.0 1.0 1.0 .0))
+ (yellow-last '(0.0 0.0 .30 .20 .80 .70 1.0 1.0))
+ (swirl-amp '(0.0 0.0 .90 1.0 1.0 .0)))
+ (bird beg 0.05 5600 400 0.05 '(0.0 0.0 0.6 1.0 1.0 0.5) main-amp)
(bird (+ beg .23) .12 5000 1500 .15 yellow-swirl swirl-amp)
(bird (+ beg .45) .13 5000 1700 .17 yellow-swirl swirl-amp)
(bird (+ beg .62) .16 5000 2000 .20 yellow-swirl swirl-amp)
@@ -197,8 +193,8 @@
;; "birds" book has piping sound coming back down whereas "songs
;; of western birds" just shows it going up.
;;
- (upamp '(.00 .00 .90 1.00 1.00 .0))
- (rampup '(.00 .00 .50 1.00 1.00 .20 )))
+ (upamp '(0.0 0.0 .90 1.0 1.0 .0))
+ (rampup '(0.0 0.0 .50 1.0 1.0 .20 )))
(bigbird beg .1 900 100 .2 rampup upamp '( 1 .5 2 1 3 .75 4 .5 5 .1))
(bigbird (+ beg .30) .1 900 200 .2 rampup upamp '( 1 .5 2 1 3 .75 4 .5 5 .1))
(bigbird (+ beg .60) .1 900 250 .2 rampup upamp '( 1 .5 2 1 3 .75 4 .5 5 .1))))))
@@ -207,13 +203,13 @@
(define b-chestnut-sided-warbler
(let ((documentation "(chestnut-sided-warbler beg) produces a chestnut sided warbler call at time 'beg'"))
(lambda (beg)
- (let ((ycurve '(.00 1.00 .30 .50 .60 1.00 .80 .20 1.00 .0))
- (vcurve '(.00 .20 .50 1.00 1.00 .0))
- (wcurve '(.00 .50 .15 .00 .45 .10 .60 1.00 .70 .90 1.00 .90 ))
- (upcurve '(.00 .00 .95 1.00 1.00 1.0))
- (downcurve '(.00 1.00 .25 .30 .60 .15 1.00 .0))
- (louder '(.00 .00 .90 1.00 1.00 .0))
- (wamp '(.00 .00 .10 1.00 .40 .10 .50 .90 .60 .10 .70 1.00 1.00 .0)))
+ (let ((ycurve '(0.0 1.0 .30 .50 .60 1.0 .80 .20 1.0 .0))
+ (vcurve '(0.0 .20 .50 1.0 1.0 .0))
+ (wcurve '(0.0 .50 .15 0.0 .45 .10 .60 1.0 .70 .90 1.0 .90 ))
+ (upcurve '(0.0 0.0 .95 1.0 1.0 1.0))
+ (downcurve '(0.0 1.0 .25 .30 .60 .15 1.0 .0))
+ (louder '(0.0 0.0 .90 1.0 1.0 .0))
+ (wamp '(0.0 0.0 .10 1.0 .40 .10 .50 .90 .60 .10 .70 1.0 1.0 .0)))
(set! beg (- beg .1))
(bigbird (+ beg .1) .1 4050 1200 .05 ycurve main-amp '(1 1 2 .1))
(bigbird (+ beg .25) .03 3900 300 .075 vcurve main-amp '(1 1 2 .1))
@@ -233,8 +229,8 @@
(define b-grasshopper-sparrow
(let ((documentation "(grasshopper-sparrow beg) produces a grasshopper sparrow call at time 'beg'"))
(lambda (beg)
- (let ((grassone '(.00 .50 .02 .80 .04 .30 .06 .80 .07 .10 .08 .90 .10 .00 .11 .90 .12 .00 .13 .90 .14 .10 .15 1.00 .16 .10 .17 1.00 .18 .10 .19 1.00 .20 .10 .21 1.00 .22 .10 .23 1.00 .24 .10 .25 1.00 .26 .10 .27 1.00 .28 .10 .29 1.00 .30 .10 .31 1.00 .32 .10 .33 1.00 .34 .10 .35 1.00 .36 .10 .37 1.00 .38 .10 .39 1.00 .40 .10 .41 1.00 .42 .10 .43 1.00 .44 .10 .45 1.00 .46 .10 .47 1.00 .48 .10 .49 1.00 .50 .10 .51 1.00 .52 .10 .53 1.00 .54 .10 .55 1.00 .56 .10 .57 1.00 .58 .10 .59 1.00 .60 .10 .61 1.00 .62 .10 .63 1.00 .64 .10 .65 1.00 .66 .10 .67 1.00 .68 .10 .69 1.00 .70 .10 .71 1.00 .72 .10 .73 1.00 .74 .10 .75 1.00 .76 .10 .77 1.00 .78 .10 .79 1.00 .80 .10 .81 1.00 .82 .10 .83 1.00 .84 .10 .85 1.00 .86 .10 .87 1.00 .88 .10 .89 1.00 .90 .10 .91 1.00 .92 .10 .93 1.00 .94 .10 .95 1.00 .96 .10 .97 1.00 .98 .10 1.00 1.0))
- (grasstwo '(.00 .00 .10 1.00 .20 .00 .30 1.00 .40 .00 .50 1.00 .60 .00 .70 1.00 .80 .00 .90 1.00 1.00 .0)))
+ (let ((grassone '(0.0 .50 .02 .80 .04 .30 .06 .80 .07 .10 .08 .90 .10 0.0 .11 .90 .12 0.0 .13 .90 .14 .10 .15 1.0 .16 .10 .17 1.0 .18 .10 .19 1.0 .20 .10 .21 1.0 .22 .10 .23 1.0 .24 .10 .25 1.0 .26 .10 .27 1.0 .28 .10 .29 1.0 .30 .10 .31 1.0 .32 .10 .33 1.0 .34 .10 .35 1.0 .36 .10 .37 1.0 .38 .10 .39 1.0 .40 .10 .41 1.0 .42 .10 .43 1.0 .44 .10 .45 1.0 .46 .10 .47 1.0 .48 .10 .49 1.0 .50 .10 .51 1.0 .52 .10 .53 1.0 .54 .10 .55 1.0 .56 .10 .57 1.0 .58 .10 .59 1.0 .60 .10 .61 1.0 .62 .10 .63 1.0 .64 .10 .65 1.0 .66 .10 .67 1.0 .68 .10 .69 1.0 .70 .10 .71 1.0 .72 .10 .73 1.0 .74 .10 .75 1.0 .76 .10 .77 1.0 .78 .10 .79 1.0 .80 .10 .81 1.0 .82 .10 .83 1.0 .84 .10 .85 1.0 .86 .10 .87 1.0 .88 .10 .89 1.0 .90 .10 .91 1.0 .92 .10 .93 1.0 .94 .10 .95 1.0 .96 .10 .97 1.0 .98 .10 1.0 1.0))
+ (grasstwo '(0.0 0.0 .10 1.0 .20 0.0 .30 1.0 .40 0.0 .50 1.0 .60 0.0 .70 1.0 .80 0.0 .90 1.0 1.0 .0)))
(set! beg (- beg .49))
(bird (+ beg .49) .01 8000 100 .1 grasstwo main-amp)
(bird (+ beg .60) .01 5700 300 .1 grasstwo main-amp)
@@ -245,8 +241,8 @@
(define b-swamp-sparrow
(let ((documentation "(swamp-sparrow beg) produces a swamp sparrow call at time 'beg'"))
(lambda (beg)
- (let ((swamp-up '(.00 .00 .60 .70 1.00 1.0))
- (swamp-down '(.00 1.00 .50 .50 .60 .60 1.00 .0)))
+ (let ((swamp-up '(0.0 0.0 .60 .70 1.0 1.0))
+ (swamp-down '(0.0 1.0 .50 .50 .60 .60 1.0 .0)))
(bird beg .02 3900 200 .3 swamp-up main-amp)
(bird (+ beg .035) .035 3200 3000 .1 swamp-down main-amp)
(bird (+ beg .08) .025 3700 0 .1 main-amp main-amp)
@@ -293,9 +289,9 @@
(lambda (beg)
(let (
;; these have as different song around here.
- (goldone '(.00 1.00 .25 .20 1.00 .0))
- (goldtwo '(.00 .90 .05 1.00 .10 .40 1.00 .0))
- (goldtrill '(.00 .50 .10 .00 .20 1.00 .30 .00 .40 1.00 .50 .00 .60 1.00 .70 .00 .80 1.00 .90 .00 1.00 .50 )))
+ (goldone '(0.0 1.0 .25 .20 1.0 .0))
+ (goldtwo '(0.0 .90 .05 1.0 .10 .40 1.0 .0))
+ (goldtrill '(0.0 .50 .10 0.0 .20 1.0 .30 0.0 .40 1.0 .50 0.0 .60 1.0 .70 0.0 .80 1.0 .90 0.0 1.0 .50 )))
(set! beg (- beg .6))
(bird (+ beg .6) .5 4300 1000 .15 goldone main-amp)
(bird (+ beg 1.3) .45 3300 200 .15 goldone main-amp)
@@ -306,17 +302,16 @@
(define b-indigo-bunting
(let ((documentation "(indigo-bunting beg) produces a indigo bunting call at time 'beg'"))
(lambda (beg)
- (let ((buntdwn '(.00 1.00 1.00 .0))
- (buntv '(.00 .00 .50 1.00 1.00 .0))
- (bunty '(.00 1.00 .50 .00 1.00 .90 ))
- (buntn '(.00 .80 .30 1.00 .70 .20 1.00 .0))
- (buntup '(.00 .00 1.00 1.0)))
+ (let ((buntdwn '(0.0 1.0 1.0 .0))
+ (buntv '(0.0 0.0 .50 1.0 1.0 .0))
+ (bunty '(0.0 1.0 .50 0.0 1.0 .90 ))
+ (buntn '(0.0 .80 .30 1.0 .70 .20 1.0 .0))
+ (buntup '(0.0 0.0 1.0 1.0)))
(set! beg (- beg .4))
(bird (+ beg .4) .08 3000 700 .25 buntdwn main-amp)
(bird (+ beg .52) .02 6200 1000 .05 buntdwn main-amp)
(bird (+ beg .55) .15 3500 2300 .1 buntv main-amp)
- (let ((buntx '(.00 1.00 .10 .50 .25 .90 1.00 .0)))
- (bird (+ beg .74) .02 6200 1800 .05 buntx main-amp))
+ (bird (+ beg .74) .02 6200 1800 .05 '(0.0 1.0 .10 .50 .25 .90 1.0 .0) main-amp)
(bird (+ beg .80) .15 3400 2300 .1 buntv main-amp)
(bird (+ beg 1.00) .1 3400 800 .2 buntv main-amp)
(bird (+ beg 1.13) .03 4100 2000 .05 buntdwn main-amp)
@@ -337,8 +332,8 @@
(define b-hooded-warbler
(let ((documentation "(hooded-warbler beg) produces a hooded warbler call at time 'beg'"))
(lambda (beg)
- (let ((hoodup '(.00 .00 1.00 1.0))
- (hooddown '(.00 1.00 1.00 .0)))
+ (let ((hoodup '(0.0 0.0 1.0 1.0))
+ (hooddown '(0.0 1.0 1.0 .0)))
(set! beg (- beg .6))
(bird (+ beg .6) .03 3900 1600 .05 hooddown main-amp)
(bird (+ beg .64) .03 3900 1700 .05 hooddown main-amp)
@@ -372,7 +367,7 @@
(define b-american-widgeon
(let ((documentation "(american-widgeon beg) produces an american widgeon call at time 'beg'"))
(lambda (beg)
- (let ((widgeon '(.00 .00 .50 1.00 1.00 .0)))
+ (let ((widgeon '(0.0 0.0 .50 1.0 1.0 .0)))
(set! beg (- beg .3))
(bigbird (+ beg .3) .07 1900 300 .15 widgeon widgeon '(1 1 2 .02))
(bigbird (+ beg .4) .11 1700 1400 .25 widgeon widgeon '(1 .7 2 1 3 .02))
@@ -382,18 +377,16 @@
(define b-louisiana-waterthrush
(let ((documentation "(louisiana-waterthrush beg) produces a louisiana waterthrush call at time 'beg'"))
(lambda (beg)
- (let ((water-four '(.00 .00 1.00 1.0))
- (water-five '(.00 1.00 1.00 .0))
- (water-damp '(.00 .00 .90 1.00 1.00 .0)))
- (let ((water-one '(.00 .80 .35 .40 .45 .90 .50 1.00 .75 1.00 1.00 .10 ))
- (water-amp '(.00 .00 .35 1.00 .50 .20 .90 1.00 1.00 .0)))
+ (let ((water-four '(0.0 0.0 1.0 1.0))
+ (water-five '(0.0 1.0 1.0 .0))
+ (water-damp '(0.0 0.0 .90 1.0 1.0 .0)))
+ (let ((water-one '(0.0 .80 .35 .40 .45 .90 .50 1.0 .75 1.0 1.0 .10 ))
+ (water-amp '(0.0 0.0 .35 1.0 .50 .20 .90 1.0 1.0 .0)))
(bird beg .17 4100 2000 .2 water-one water-amp)
(bird (+ beg .32) .18 4050 2050 .3 water-one water-amp)
(bird (+ beg .64) .20 4000 1900 .25 water-one water-amp))
- (let ((water-two '(.00 1.00 .40 .00 .60 .10 1.00 .80 )))
- (bird (+ beg .9) .2 3900 2000 .3 water-two bird-tap))
- (let ((water-three '(.00 1.00 .95 .00 1.00 .0)))
- (bird (+ beg 1.25) .12 3000 3000 .25 water-three water-damp))
+ (bird (+ beg .9) .2 3900 2000 .3 '(0.0 1.0 .40 0.0 .60 .10 1.0 .80 ) bird-tap)
+ (bird (+ beg 1.25) 0.12 3000 3000 0.25 '(0.0 1.0 0.95 0.0 1.0 0.0) water-damp)
(bird (+ beg 1.4) .1 2700 1500 .2 water-four water-damp)
(bird (+ beg 1.58) .02 5200 1000 .1 water-five main-amp)
(bird (+ beg 1.65) .02 5200 1000 .1 water-five main-amp)
@@ -404,31 +397,27 @@
(let ((documentation "(robin beg) produces a robin call at time 'beg'"))
(lambda (beg)
(set! beg (- beg .45))
- (let ((r-six '(.00 .00 .12 .70 .30 .00 .70 1.00 1.00 .50 )))
- (bigbird (+ beg .45) .06 2000 800 .15 r-six main-amp '(1 1 2 .1)))
- (let ((r-one '(.00 .10 .08 .70 .30 .00 .35 1.00 .40 .30 1.00 .30 )))
- (bigbird (+ beg .56) .10 2000 900 .15 r-one main-amp '(1 1 2 .1)))
- (let ((r-two '(.00 .00 .10 1.00 .20 .70 .35 .70 .65 .30 .70 .50 .80 .00 .90 .20 1.00 .0)))
- (bigbird (+ beg 1.04) .24 2000 2000 .25 r-two main-amp '(1 1 2 .1)))
- (let ((r-three '(.00 .20 .25 1.00 .60 .70 .90 .00 1.00 .10 )))
- (bigbird (+ beg 1.63) .13 1900 1600 .20 r-three main-amp '(1 1 2 .1)))
- (let ((r-four '(.00 1.00 1.00 .0)))
- (bigbird (+ beg 1.80) .11 2200 1200 .25 r-four main-amp '(1 1 2 .1)))
- (let ((r-five '(.00 .50 .10 .00 .20 1.00 .30 .00 .40 1.00 .50 .00 .60 1.00 .70 .50 1.00 .20 )))
- (bigbird (+ beg 2.31) .21 1950 2000 .15 r-five main-amp '(1 1 2 .1))))))
+ (bigbird (+ beg .45) .06 2000 800 .15 '(0.0 0.0 .12 .70 .30 0.0 .70 1.0 1.0 .50 ) main-amp '(1 1 2 .1))
+ (bigbird (+ beg .56) .10 2000 900 .15 '(0.0 .10 .08 .70 .30 0.0 .35 1.0 .40 .30 1.0 .30 ) main-amp '(1 1 2 .1))
+ (bigbird (+ beg 1.04) .24 2000 2000 .25 '(0.0 0.0 .10 1.0 .20 .70 .35 .70 .65 .30 .70 .50 .80 0.0 .90 .20 1.0 .0) main-amp '(1 1 2 .1))
+ (bigbird (+ beg 1.63) .13 1900 1600 .20 '(0.0 .20 .25 1.0 .60 .70 .90 0.0 1.0 .10 ) main-amp '(1 1 2 .1))
+ (bigbird (+ beg 1.80) .11 2200 1200 .25 '(0.0 1.0 1.0 .0) main-amp '(1 1 2 .1))
+ (bigbird (+ beg 2.31) .21 1950 2000 .15 '(0.0 .50 .10 0.0 .20 1.0 .30 0.0 .40 1.0 .50 0.0 .60 1.0 .70 .50 1.0 .20 ) main-amp '(1 1 2 .1)))))
(define b-solitary-vireo
(let ((documentation "(solitary-vireo beg) produces a solitary vireo call at time 'beg'"))
(lambda (beg)
- (let ((bigskew '(.00 .20 .03 .30 .06 .10 .10 .50 .13 .40 .16 .80 .19 .50 .22 .90 .25 .60 .28 1.00 .31 .60 .34 1.00 .37 .50 .41 .90 .45 .40 .49 .80 .51 .40 .54 .75 .57 .35 .60 .70 .63 .30 .66 .60 .69 .25 .72 .50 .75 .20 .78 .30 .82 .10 .85 .30 .88 .05 .91 .30 .94 .00 .95 .30 .99 .00 1.00 .10 )))
- (bird beg .4 1800 1200 .2 bigskew main-amp)))))
+ (bird beg .4 1800 1200 .2
+ '(0.0 .20 .03 .30 .06 .10 .10 .50 .13 .40 .16 .80 .19 .50 .22 .90 .25 .60 .28 1.0 .31 .60 .34 1.0 .37 .50 .41 .90 .45 .40 .49 .80
+ .51 .40 .54 .75 .57 .35 .60 .70 .63 .30 .66 .60 .69 .25 .72 .50 .75 .20 .78 .30 .82 .10 .85 .30 .88 .05 .91 .30 .94 0.0 .95 .30 .99 0.0 1.0 .10)
+ main-amp))))
(define b-pigeon-hawk
(let ((documentation "(pigeon-hawk beg) produces a pigeon hawk (merlin) call at time 'beg'"))
(lambda (beg)
- (let ((hupdown '(.00 .00 .30 1.00 .70 1.00 1.00 .0)))
+ (let ((hupdown '(0.0 0.0 .30 1.0 .70 1.0 1.0 .0)))
(bigbird beg .1 1900 200 .2 hupdown main-amp '(1 .7 2 1))
(bigbird (+ beg .12) .01 2050 0 .1 main-amp main-amp '(1 .5 2 1))
(bigbird (+ beg .13) .1 1900 200 .2 hupdown main-amp '(1 .7 2 1))
@@ -463,16 +452,16 @@
(define b-cerulean-warbler
(let ((documentation "(cerulean-warbler beg) produces a cerulean warbler call at time 'beg'"))
(lambda (beg)
- (let ((w-up '(.00 .00 1.00 1.0)))
+ (let ((w-up '(0.0 0.0 1.0 1.0)))
(set! beg (- beg .27))
- (let ((w-down '(.00 1.00 1.00 .0)))
+ (let ((w-down '(0.0 1.0 1.0 .0)))
(bird (+ beg .27) .05 3000 1000 .05 w-down main-amp)
(bird (+ beg .33) .05 3000 800 .075 w-up main-amp)
(bird (+ beg .41) .01 3200 700 .07 w-down main-amp)
(bird (+ beg .42) .01 3200 700 .08 w-down main-amp)
(bird (+ beg .43) .06 3200 700 .09 w-down main-amp))
(bird (+ beg .51) .06 3200 500 .1 w-up main-amp)
- (let ((trill '(.00 .80 .10 1.00 .25 .50 .40 1.00 .55 .50 .70 1.00 1.00 .0)))
+ (let ((trill '(0.0 .80 .10 1.0 .25 .50 .40 1.0 .55 .50 .70 1.0 1.0 .0)))
(bird (+ beg .6) .10 3000 1200 .2 trill main-amp)
(bird (+ beg .72) .05 3000 800 .2 w-up main-amp)
(bird (+ beg .8) .10 3000 1200 .2 trill main-amp))
@@ -513,10 +502,10 @@
(define b-nashville-warbler
(let ((documentation "(nashville-warbler beg) produces a nashville warbler call at time 'beg'"))
(lambda (beg)
- (let ((nash-blip '(.00 .60 .35 1.00 1.00 .0))
- (nash-down '(.00 .90 .05 1.00 .10 .90 .65 .50 1.00 .0))
- (nash-up '(.00 .00 .15 .20 .25 .05 .90 .95 1.00 1.0))
- (nash-amp '(.00 .00 .80 1.00 1.00 .0)))
+ (let ((nash-blip '(0.0 .60 .35 1.0 1.0 .0))
+ (nash-down '(0.0 .90 .05 1.0 .10 .90 .65 .50 1.0 .0))
+ (nash-up '(0.0 0.0 .15 .20 .25 .05 .90 .95 1.0 1.0))
+ (nash-amp '(0.0 0.0 .80 1.0 1.0 .0)))
(set! beg (- beg .15))
(bird (+ beg .15) .025 3900 300 .3 nash-blip main-amp)
(bird (+ beg .24) .16 4200 3800 .15 nash-down nash-amp)
@@ -536,58 +525,48 @@
(define b-eastern-phoebe
(let ((documentation "(eastern-phoebe beg) produces an eastern-phoebe call at time 'beg'"))
(lambda (beg)
- (let ((phoebe-amp '(.00 .00 .10 1.00 1.00 .0)))
- (let ((phoebe-one '(.00 .00 .30 .30 .35 .50 .55 .40 .70 .80 .75 .70 .80 1.00 .95 .90 1.00 .0)))
- (bird beg .225 3000 1300 .3 phoebe-one main-amp))
- (let ((phoebe-two '(.00 .00 .50 1.00 1.00 .0)))
- (bird (+ beg .35) .12 3000 500 .1 phoebe-two phoebe-amp))
- (let ((phoebe-three '(.00 .00 .10 .40 .80 1.00 1.00 .10 )))
- (bird (+ beg .4) .10 3000 1500 .2 phoebe-three phoebe-amp))
- (let ((phoebe-four '(.00 1.00 .50 .70 1.00 .0)))
- (bird (+ beg .55) .05 3000 1400 .2 phoebe-four phoebe-amp))))))
+ (let ((phoebe-amp '(0.0 0.0 .10 1.0 1.0 .0)))
+ (bird beg .225 3000 1300 .3 '(0.0 0.0 .30 .30 .35 .50 .55 .40 .70 .80 .75 .70 .80 1.0 .95 .90 1.0 .0) main-amp)
+ (bird (+ beg .35) .12 3000 500 .1 '(0.0 0.0 .50 1.0 1.0 .0) phoebe-amp)
+ (bird (+ beg .4) .10 3000 1500 .2 '(0.0 0.0 .10 .40 .80 1.0 1.0 .10 ) phoebe-amp)
+ (bird (+ beg .55) .05 3000 1400 .2 '(0.0 1.0 .50 .70 1.0 .0) phoebe-amp)))))
(define b-painted-bunting
(let ((documentation "(painted-bunting beg) produces a painted bunting call at time 'beg'"))
(lambda (beg)
- (let ((b-one '(.00 .00 1.00 1.0)))
+ (let ((b-one '(0.0 0.0 1.0 1.0)))
(set! beg (- beg .05))
- (let ((b-two '(.00 .00 .90 1.00 1.00 .0)))
- (bird (+ beg .05) .10 3100 900 .05 b-one b-two))
- (let ((b-three '(.00 1.00 1.00 .0)))
- (bird (+ beg .21) .07 4100 700 .15 b-three main-amp))
- (let ((b-four '(.00 .00 .50 1.00 1.00 .0)))
- (bird (+ beg .36) .12 3700 1000 .20 b-four main-amp))
- (let ((b-five '(.00 .70 .15 .00 .40 1.00 .80 1.00 1.00 .50 ))
- (b-six '(.00 .00 .10 .50 .15 .00 .40 1.00 .90 1.00 1.00 .0)))
- (bird (+ beg .52) .08 2300 1600 .15 b-five b-six))
+ (bird (+ beg .05) .10 3100 900 .05 b-one '(0.0 0.0 .90 1.0 1.0 .0))
+ (bird (+ beg .21) .07 4100 700 .15 '(0.0 1.0 1.0 .0) main-amp)
+ (bird (+ beg .36) .12 3700 1000 .20 '(0.0 0.0 .50 1.0 1.0 .0) main-amp)
+ (bird (+ beg .52) .08 2300 1600 .15
+ '(0.0 .70 .15 0.0 .40 1.0 .80 1.0 1.0 .50 )
+ '(0.0 0.0 .10 .50 .15 0.0 .40 1.0 .90 1.0 1.0 .0))
(bird (+ beg .68) .1 4000 1000 .25 b-one bird-tap)
- (let ((b-seven '(.00 1.00 .25 .40 .75 .50 1.00 .0)))
- (bird (+ beg .8) .12 2300 1700 .2 b-seven main-amp))
- (let ((b-eight '(.00 .30 .40 .40 .50 1.00 .60 .20 1.00 .0))
- (b-nine '(.00 .00 .05 1.00 .30 1.00 .50 .30 .90 1.00 1.00 .0)))
- (bird (+ beg .96) .15 3800 2200 .3 b-eight b-nine))
- (let ((b-ten '(.00 .40 .25 .00 .35 1.00 .50 .00 .65 1.00 .75 .00 .85 1.00 1.00 .0)))
- (bird (+ beg 1.18) .1 2300 1600 .15 b-ten main-amp))
- (let ((b-eleven '(.00 1.00 1.00 .0)))
+ (bird (+ beg .8) .12 2300 1700 .2 '(0.0 1.0 .25 .40 .75 .50 1.0 .0) main-amp)
+ (bird (+ beg .96) .15 3800 2200 .3
+ '(0.0 .30 .40 .40 .50 1.0 .60 .20 1.0 .0)
+ '(0.0 0.0 .05 1.0 .30 1.0 .50 .30 .90 1.0 1.0 .0))
+ (bird (+ beg 1.18) .1 2300 1600 .15 '(0.0 .40 .25 0.0 .35 1.0 .50 0.0 .65 1.0 .75 0.0 .85 1.0 1.0 .0) main-amp)
+ (let ((b-eleven '(0.0 1.0 1.0 .0)))
(bird (+ beg 1.3) .02 3200 1000 .1 b-eleven main-amp)
(bird (+ beg 1.33) .02 3200 1000 .1 b-eleven main-amp)
(bird (+ beg 1.36) .02 3200 1000 .1 b-eleven main-amp))
- (let ((b-twelve '(.00 .00 .50 1.00 1.00 .50 ))
- (b-thirteen '(.00 .00 .05 1.00 .30 .20 .60 .20 .90 1.00 1.00 .0)))
- (bird (+ beg 1.40) .03 4000 2000 .12 b-twelve b-thirteen))
- (let ((b-fourteen '(.00 .30 .30 1.00 .60 .30 1.00 .0))
- (b-fifteen '(.00 .00 .10 .50 .50 .50 .90 1.00 1.00 .0)))
- (bird (+ beg 1.47) .1 2300 1700 .2 b-fourteen b-fifteen))))))
-
+ (bird (+ beg 1.40) .03 4000 2000 .12
+ '(0.0 0.0 .50 1.0 1.0 .50 )
+ '(0.0 0.0 .05 1.0 .30 .20 .60 .20 .90 1.0 1.0 .0))
+ (bird (+ beg 1.47) .1 2300 1700 .2
+ '(0.0 .30 .30 1.0 .60 .30 1.0 .0)
+ '(0.0 0.0 .10 .50 .50 .50 .90 1.0 1.0 .0))))))
(define b-western-flycatcher
(let ((documentation "(western-flycatcher beg) produces a western flycatcher call at time 'beg'"))
(lambda (beg)
- (let ((f-one '(.00 .00 .10 1.00 .20 .40 .95 .10 1.00 .0))
- (a-one '(.00 .00 .10 .20 .20 .10 .30 1.00 .90 1.00 1.00 .0))
- (f-two '(.00 .50 .25 1.00 .50 .00 .60 .00 .95 .30 1.00 .60 ))
- (a-two '(.00 .00 .10 1.00 .20 1.00 .50 .10 .60 .10 .90 1.00 1.00 .0)))
+ (let ((f-one '(0.0 0.0 .10 1.0 .20 .40 .95 .10 1.0 .0))
+ (a-one '(0.0 0.0 .10 .20 .20 .10 .30 1.0 .90 1.0 1.0 .0))
+ (f-two '(0.0 .50 .25 1.0 .50 0.0 .60 0.0 .95 .30 1.0 .60 ))
+ (a-two '(0.0 0.0 .10 1.0 .20 1.0 .50 .10 .60 .10 .90 1.0 1.0 .0)))
(bigbird beg .2 2000 2200 .2 f-one a-one '(1 1 2 .02 3 .1 4 .01))
(bigbird (+ beg .3) .2 2000 1100 .2 f-two a-two '(1 1 2 .02 3 .1 4 .01))))))
@@ -595,10 +574,9 @@
(define b-bachmans-sparrow
(let ((documentation "(bachmans-sparrow beg) produces a bachmans sparrow call at time 'beg'"))
(lambda (beg)
- (let ((sup '(.00 .10 .35 .00 1.00 1.0))
- (sdwn '(.00 1.00 .40 .50 1.00 .0)))
- (let ((sopening '(.00 1.00 .10 .50 .90 .50 1.00 .0)))
- (bird beg .51 4900 200 .3 sopening main-amp))
+ (let ((sup '(0.0 .10 .35 0.0 1.0 1.0))
+ (sdwn '(0.0 1.0 .40 .50 1.0 .0)))
+ (bird beg .51 4900 200 .3 '(0.0 1.0 .10 .50 .90 .50 1.0 .0) main-amp)
(bird (+ beg .52) .015 3800 200 .1 sup main-amp)
(bird (+ beg .52) .015 3750 250 .1 sup main-amp)
(bird (+ beg .54) .015 3600 300 .1 sup main-amp)
@@ -622,7 +600,7 @@
(bird (+ beg 1.55) .07 3000 750 .2 sup main-amp)
(bird (+ beg 1.63) .03 5000 1000 .1 sdwn main-amp)
- (let ((supn '(.00 .00 1.00 1.0)))
+ (let ((supn '(0.0 0.0 1.0 1.0)))
(bird (+ beg 2.8) .06 4000 1700 .1 supn main-amp)
(bird (+ beg 2.87) .01 5200 0 .2 supn main-amp)
(bird (+ beg 2.9) .06 4000 1700 .1 supn main-amp)
@@ -634,7 +612,7 @@
(bird (+ beg 3.2) .06 4000 1700 .1 supn main-amp)
(bird (+ beg 3.27) .01 5200 0 .2 supn main-amp))
- (let ((slast '(.00 1.00 .25 .00 .75 .40 1.00 .50 )))
+ (let ((slast '(0.0 1.0 .25 0.0 .75 .40 1.0 .50 )))
(bird (+ beg 3.4) .15 3000 1000 .2 slast main-amp)
(bird (+ beg 3.6) .15 3000 1000 .2 slast main-amp)
(bird (+ beg 3.8) .15 3000 1000 .2 slast main-amp)
@@ -646,17 +624,16 @@
(define b-cedar-waxwing
(let ((documentation "(cedar-waxwing beg) produces a cedar waxwing call at time 'beg'"))
(lambda (beg)
- (let ((cedar '(.00 .00 .25 .70 .70 1.00 .90 1.00 1.00 .20 ))
- (cedamp '(.00 .00 .20 1.00 .40 1.00 1.00 .0)))
- (bird beg .50 6000 800 .2 cedar cedamp)))))
-
+ (bird beg .50 6000 800 .2
+ '(0.0 0.0 .25 .70 .70 1.0 .90 1.0 1.0 .20 )
+ '(0.0 0.0 .20 1.0 .40 1.0 1.0 .0)))))
(define b-bairds-sparrow
(let ((documentation "(bairds-sparrow beg) produces a bairds sparrow call at time 'beg'"))
(lambda (beg)
- (let ((bairdend '(.00 .00 .25 1.00 .50 .00 .75 1.00 1.00 .0)))
- (let ((bairdstart '(.00 .50 .05 1.00 .10 .00 .15 1.00 .20 .00 .25 1.00 .30 .00 .35 1.00 .40 .00 .45 1.00
- .50 .00 .55 1.00 .60 .00 .65 1.00 .70 .00 .75 1.00 .80 .00 .85 1.00 .90 .00 .95 1.00 1.00 .0)))
+ (let ((bairdend '(0.0 0.0 .25 1.0 .50 0.0 .75 1.0 1.0 .0)))
+ (let ((bairdstart '(0.0 .50 .05 1.0 .10 0.0 .15 1.0 .20 0.0 .25 1.0 .30 0.0 .35 1.0 .40 0.0 .45 1.0
+ .50 0.0 .55 1.0 .60 0.0 .65 1.0 .70 0.0 .75 1.0 .80 0.0 .85 1.0 .90 0.0 .95 1.0 1.0 .0)))
(bird beg .09 6500 1500 .2 bairdstart main-amp)
(bird (+ beg .22) .01 5900 100 .2 bairdend main-amp)
(bird (+ beg .25) .09 6000 1000 .2 bairdstart main-amp)
@@ -701,13 +678,12 @@
(define b-kentucky-warbler
(let ((documentation "(kentucky-warbler beg) produces a kentucky warbler call at time 'beg'"))
(lambda (beg)
- (let ((kenstart '(.00 .30 .50 1.00 1.00 .0))
- (kendwn '(.00 .90 .10 1.00 1.00 .0))
- (kentrill '(.00 1.00 .25 .00 .50 .00 .75 1.00 1.00 .0)))
+ (let ((kenstart '(0.0 .30 .50 1.0 1.0 .0))
+ (kendwn '(0.0 .90 .10 1.0 1.0 .0))
+ (kentrill '(0.0 1.0 .25 0.0 .50 0.0 .75 1.0 1.0 .0)))
(set! beg (- beg .6))
(bigbird (+ beg .6) .02 3800 200 .05 kenstart main-amp '(1 1 2 .03))
- (let ((kenup '(.00 .00 1.00 1.0)))
- (bigbird (+ beg .65) .03 4300 200 .15 kenup main-amp '(1 1 2 .1)))
+ (bigbird (+ beg .65) .03 4300 200 .15 '(0.0 0.0 1.0 1.0) main-amp '(1 1 2 .1))
(bigbird (+ beg .73) .02 3200 100 .1 kendwn main-amp '(1 1 2 .1))
(bigbird (+ beg .75) .05 3000 800 .15 kenstart main-amp '(1 1 2 .01))
@@ -742,11 +718,11 @@
(define b-rufous-sided-towhee
(let ((documentation "(rufous-sided-towhee beg) produces a rufous sided towhee call at time 'beg'"))
(lambda (beg)
- (let ((towhee-two '(.00 .00 1.00 1.0))
- (towhee-three '(.00 1.00 1.00 .0)))
+ (let ((towhee-two '(0.0 0.0 1.0 1.0))
+ (towhee-three '(0.0 1.0 1.0 .0)))
(set! beg (- beg .25))
- (let ((towhee-one '(.00 .10 .02 .05 .04 .15 .06 .05 .08 .20 .10 .04 .12 .25 .14 .03 .16 .30 .18 .02 .20 .35 .22 .01 .24
- .40 .26 .00 .28 .45 .30 .00 .32 .50 .34 .00 .36 .50 .80 1.00 1.00 .0)))
+ (let ((towhee-one '(0.0 .10 .02 .05 .04 .15 .06 .05 .08 .20 .10 .04 .12 .25 .14 .03 .16 .30 .18 .02 .20 .35 .22 .01 .24
+ .40 .26 0.0 .28 .45 .30 0.0 .32 .50 .34 0.0 .36 .50 .80 1.0 1.0 .0)))
(bigbird (+ beg .25) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
(bigbird (+ beg .45) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
(bigbird (+ beg .60) .13 1400 1100 .2 towhee-one main-amp '(1 .03 2 1 3 .03))
@@ -806,9 +782,9 @@
(define b-prothonotary-warbler
(let ((documentation "(prothonotary-warbler beg) produces a prothonotary warbler call at time 'beg'"))
(lambda (beg)
- (let ((pro-one '(.00 .10 .20 .00 1.00 1.0))
- (pro-two '(.00 .00 1.00 1.0))
- (pro-amp '(.00 .00 .20 1.00 .40 .50 1.00 .0)))
+ (let ((pro-one '(0.0 .10 .20 0.0 1.0 1.0))
+ (pro-two '(0.0 0.0 1.0 1.0))
+ (pro-amp '(0.0 0.0 .20 1.0 .40 .50 1.0 .0)))
(set! beg (- beg .76))
(bird (+ beg .76) .08 3000 3000 .05 pro-one pro-amp)
(bird (+ beg .85) .05 4000 2500 .06 pro-two bird-amp)
@@ -837,10 +813,10 @@
(lambda (beg)
(let (
;; (yellow-rumped say the revisionists))
- (w-up '(.00 .00 1.00 1.0))
- (w-down '(.00 1.00 1.00 .0))
- (w-end '(.00 .00 .15 1.00 .45 .90 .50 .00 .55 1.00 .90 .90 1.00 .10 ))
- (w-updown '(.00 .10 .50 1.00 1.00 .0)))
+ (w-up '(0.0 0.0 1.0 1.0))
+ (w-down '(0.0 1.0 1.0 .0))
+ (w-end '(0.0 0.0 .15 1.0 .45 .90 .50 0.0 .55 1.0 .90 .90 1.0 .10 ))
+ (w-updown '(0.0 .10 .50 1.0 1.0 .0)))
(set! beg (- beg .75))
(bird (+ beg .75) .04 2400 200 .05 w-down bird-amp)
(bird (+ beg .83) .03 3200 200 .1 w-up bird-amp)
@@ -867,10 +843,10 @@
(define b-lark-bunting
(let ((documentation "(lark-bunting beg) produces a lark bunting call at time 'beg'"))
(lambda (beg)
- (let ((b-down '(.00 1.00 1.00 .0))
- (b-up '(.00 .00 1.00 1.0))
- (b-trill-one '(.00 .00 .06 .80 .12 .00 .18 .85 .24 .05 .36 .90 .42 .10 .48 .95 .54 .20 .60 1.00 .66 .20 .72 1.00 .78 .20 .84 1.00 .90 .20 1.00 1.0))
- (b-trill-two '(.00 .00 .05 .80 .10 .00 .15 .85 .20 .00 .25 .90 .30 .00 .35 .95 .40 .00 .45 1.00 .50 .00 .55 1.00 .60 .00 .65 1.00 .70 .00 .75 1.00 .80 .00 .85 1.00 .90 .00 .95 1.00 1.00 .0)))
+ (let ((b-down '(0.0 1.0 1.0 .0))
+ (b-up '(0.0 0.0 1.0 1.0))
+ (b-trill-one '(0.0 0.0 .06 .80 .12 0.0 .18 .85 .24 .05 .36 .90 .42 .10 .48 .95 .54 .20 .60 1.0 .66 .20 .72 1.0 .78 .20 .84 1.0 .90 .20 1.0 1.0))
+ (b-trill-two '(0.0 0.0 .05 .80 .10 0.0 .15 .85 .20 0.0 .25 .90 .30 0.0 .35 .95 .40 0.0 .45 1.0 .50 0.0 .55 1.0 .60 0.0 .65 1.0 .70 0.0 .75 1.0 .80 0.0 .85 1.0 .90 0.0 .95 1.0 1.0 .0)))
(set! beg (- beg .1))
(bird (+ beg .1) .03 1800 100 .1 b-up bird-amp)
(bird (+ beg .2) .12 3700 400 .2 b-up bird-amp)
@@ -910,11 +886,11 @@
(define b-eastern-bluebird
(let ((documentation "(eastern-bluebird beg) produces an eastern bluebird call at time 'beg'"))
(lambda (beg)
- (let ((blue-one '(.00 .00 1.00 1.0))
- (blue-two '(.00 1.00 1.00 .0))
- (blue-three '(.00 .60 .10 1.00 .20 .00 .25 1.00 .30 .00 .35 1.00 .40 .00 .45 1.00 .50 .00 .75 1.00 1.00 .0))
- (blue-four '(.00 .00 .50 1.00 1.00 .0))
- (blue-five '(.00 .50 .10 1.00 .20 .00 .35 1.00 .50 .00 .65 1.00 .80 .00 .95 1.00 1.00 .50 )))
+ (let ((blue-one '(0.0 0.0 1.0 1.0))
+ (blue-two '(0.0 1.0 1.0 .0))
+ (blue-three '(0.0 .60 .10 1.0 .20 0.0 .25 1.0 .30 0.0 .35 1.0 .40 0.0 .45 1.0 .50 0.0 .75 1.0 1.0 .0))
+ (blue-four '(0.0 0.0 .50 1.0 1.0 .0))
+ (blue-five '(0.0 .50 .10 1.0 .20 0.0 .35 1.0 .50 0.0 .65 1.0 .80 0.0 .95 1.0 1.0 .50 )))
(set! beg (- beg .75))
(bird (+ beg .75) .02 2000 1600 .1 blue-one bird-amp)
(bird (+ beg .80) .02 2000 1600 .1 blue-one bird-amp)
@@ -929,9 +905,9 @@
(define b-chuck-wills-widow
(let ((documentation "(chuck-wills-widow beg) produces a chuck wills widow call at time 'beg'"))
(lambda (beg)
- (let ((wid-down '(.00 1.00 1.00 .0))
- (wid-one '(.00 .00 .10 .10 .25 1.00 .50 .30 .80 .70 1.00 .0))
- (wid-two '(.00 .20 .30 1.00 .50 .30 .60 .70 .90 .10 1.00 .0)))
+ (let ((wid-down '(0.0 1.0 1.0 .0))
+ (wid-one '(0.0 0.0 .10 .10 .25 1.0 .50 .30 .80 .70 1.0 .0))
+ (wid-two '(0.0 .20 .30 1.0 .50 .30 .60 .70 .90 .10 1.0 .0)))
(set! beg (- beg .05))
(bird (+ beg .05) .03 1000 800 .1 wid-down bird-amp)
(bird (+ beg .32) .20 1000 1000 .2 wid-one bird-amp)
@@ -941,8 +917,8 @@
(define b-blue-gray-gnatcatcher
(let ((documentation "(blue-gray-gnatcatcher beg) produces a blue gray gnatcatcher call at time 'beg'"))
(lambda (beg)
- (let ((gskw1 '(.00 .00 .15 1.00 .75 .80 .90 1.00 1.00 .70 ))
- (gskw2 '(.00 .00 .25 1.00 .75 .70 1.00 .0)))
+ (let ((gskw1 '(0.0 0.0 .15 1.0 .75 .80 .90 1.0 1.0 .70 ))
+ (gskw2 '(0.0 0.0 .25 1.0 .75 .70 1.0 .0)))
(set! beg (- beg .5))
(bigbird (+ beg .5) .20 4000 1000 .2 gskw1 bird-amp '(1 .4 2 1 3 .1))
(bigbird (+ beg .8) .13 4000 800 .2 gskw2 bird-amp '(1 .4 2 1 3 .2))
@@ -956,23 +932,23 @@
(define b-black-throated-sparrow
(let ((documentation "(black-throated-sparrow beg) produces a black throated sparrow call at time 'beg'"))
(lambda (beg)
- (let ((black-up '(.00 .00 1.00 1.0))
- (black-amp '(.00 .00 .50 1.00 1.00 .0)))
+ (let ((black-up '(0.0 0.0 1.0 1.0))
+ (black-amp '(0.0 0.0 .50 1.0 1.0 .0)))
(set! beg (- beg .8))
- (let ((black-down '(.00 1.00 1.00 .0))
- (black-down-amp '(.00 .00 .75 1.00 1.00 .0)))
+ (let ((black-down '(0.0 1.0 1.0 .0))
+ (black-down-amp '(0.0 0.0 .75 1.0 1.0 .0)))
(bird (+ beg .8) .02 2200 1000 .1 black-down bird-amp)
(bird (+ beg .83) .01 3000 200 .05 black-up bird-amp)
(bird (+ beg .96) .02 5800 500 .05 black-up bird-amp)
(bird (+ beg 1.00) .02 4000 200 .05 black-up bird-amp)
(bird (+ beg 1.04) .10 2100 1700 .15 black-down black-down-amp))
(bird (+ beg 1.15) .05 5700 400 .25 black-up bird-amp)
- (let ((black-trill '(.00 .00 .03 .70 .06 .00 .09 .75 .12 .00 .15 .80 .18 .05 .21 .85 .24 .10 .27 .90
- .30 .10 .33 1.00 .36 .10 .39 1.00 .42 .10 .45 1.00 .48 .10 .51 1.00 .54 .10 .57 1.00
- .60 .10 .63 1.00 .66 .10 .69 1.00 .72 .10 .75 1.00 .78 .10 .81 1.00 .84 .10 .87 1.00 .90 .00 .93 .95 .96 .00 1.00 .90 )))
- (bird (+ beg 1.25) .25 2000 900 .2 black-trill bird-amp))
- (let ((black-up-down '(.00 .00 .50 1.00 1.00 .20 )))
- (bird (+ beg 1.52) .05 5600 400 .15 black-up-down bird-amp))
+ (bird (+ beg 1.25) .25 2000 900 .2
+ '(0.0 0.0 .03 .70 .06 0.0 .09 .75 .12 0.0 .15 .80 .18 .05 .21 .85 .24 .10 .27 .90
+ .30 .10 .33 1.0 .36 .10 .39 1.0 .42 .10 .45 1.0 .48 .10 .51 1.0 .54 .10 .57 1.0
+ .60 .10 .63 1.0 .66 .10 .69 1.0 .72 .10 .75 1.0 .78 .10 .81 1.0 .84 .10 .87 1.0 .90 0.0 .93 .95 .96 0.0 1.0 .90 )
+ bird-amp)
+ (bird (+ beg 1.52) .05 5600 400 .15 '(0.0 0.0 .50 1.0 1.0 .20) bird-amp)
(bird (+ beg 1.6) .04 3900 1100 .15 black-up bird-amp)
(bird (+ beg 1.66) .01 1900 100 .10 black-up black-amp)
@@ -1008,10 +984,10 @@
(define b-black-chinned-sparrow
(let ((documentation "(black-chinned-sparrow beg) produces a black chinned sparrow call at time 'beg'"))
(lambda (beg)
- (let ((chin-up '(.00 .00 1.00 1.0)))
+ (let ((chin-up '(0.0 0.0 1.0 1.0)))
(set! beg (- beg .6))
(bird (+ beg .6) .2 4200 100 .1 chin-up bird-amp)
- (let ((chin-up2 '(.00 .00 .30 .20 1.00 1.0)))
+ (let ((chin-up2 '(0.0 0.0 .30 .20 1.0 1.0)))
(bird (+ beg 1.0) .09 3800 2000 .1 chin-up2 bird-amp)
(bird (+ beg 1.25) .08 3900 1700 .12 chin-up2 bird-amp))
(bird (+ beg 1.40) .08 3600 2300 .13 chin-up bird-amp)
@@ -1034,38 +1010,19 @@
(lambda (beg)
(let ((gullstart '(0 0 10 1 20 .5000 40 .6000 60 .5000 100 0 ))
(gullmiddle '(0 0 10 1 30 .5000 80 .5000 100 0 ))
- (gullend '(0 0 5 1 10 .5000 90 .4000 100 0 )))
+ (gullend '(0 0 5 1 10 .5000 90 .4000 100 0 ))
+ (gull-frq '(1 .1 2 1 3 .1 4 .01 5 .09 6 .01 7 .01)))
(set! beg (- beg .25))
- (bigbird (+ beg .250) .80 1180 1180 .08 gullend bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 1.500) .90 1180 1180 .07 gullend bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 2.750) 1.00 1050 1050 .08 gullend bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 4.800) .05 1180 1180 .06 gullstart bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 4.950) .10 1180 1180 .08 gullstart bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 5.150) .10 1180 1180 .09 gullstart bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 5.350) .10 1180 1180 .1 gullmiddle bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 5.450) .40 1050 1050 .1 gullend bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 6.250) .80 1050 1050 .1 gullend bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))
- (bigbird (+ beg 7.450) 1.80 1050 1050 .1 gullend bird-amp
- '(1 .1 2 1 3 .1 4 .01 5
- .09 6 .01 7 .01))))))
+ (bigbird (+ beg .250) .80 1180 1180 .08 gullend bird-amp gull-frq)
+ (bigbird (+ beg 1.500) .90 1180 1180 .07 gullend bird-amp gull-frq)
+ (bigbird (+ beg 2.750) 1.0 1050 1050 .08 gullend bird-amp gull-frq)
+ (bigbird (+ beg 4.800) .05 1180 1180 .06 gullstart bird-amp gull-frq)
+ (bigbird (+ beg 4.950) .10 1180 1180 .08 gullstart bird-amp gull-frq)
+ (bigbird (+ beg 5.150) .10 1180 1180 .09 gullstart bird-amp gull-frq)
+ (bigbird (+ beg 5.350) .10 1180 1180 .1 gullmiddle bird-amp gull-frq)
+ (bigbird (+ beg 5.450) .40 1050 1050 .1 gullend bird-amp gull-frq)
+ (bigbird (+ beg 6.250) .80 1050 1050 .1 gullend bird-amp gull-frq)
+ (bigbird (+ beg 7.450) 1.80 1050 1050 .1 gullend bird-amp gull-frq)))))
(define make-birds
diff --git a/clean.scm b/clean.scm
index 3ea8ab9..e31a2ef 100644
--- a/clean.scm
+++ b/clean.scm
@@ -6,8 +6,7 @@
(define goertzel-channel
(let ((documentation "(goertzel-channel freq beg dur snd (chn 0)) returns the amplitude of the 'freq' spectral component"))
(lambda* (freq (beg 0) dur snd chn)
- (let* ((sr (srate snd))
- (rfreq (/ (* 2.0 pi freq) sr))
+ (let* ((rfreq (/ (* 2.0 pi freq) (srate snd)))
(cs (* 2.0 (cos rfreq))))
(let ((reader (make-sampler beg snd chn))
(len (- (if (number? dur) dur (- (framples snd chn) beg)) 2))
@@ -158,14 +157,12 @@
(do ((ctr 0 (+ ctr 1)))
((= ctr len))
(let* ((ahead-samp (next-sample reader))
- (diff-ahead (abs (- ahead-samp last-ahead-samp)))
- (avg-ahead (moving-average mx-ahead diff-ahead))
+ (avg-ahead (moving-average mx-ahead (abs (- ahead-samp last-ahead-samp))))
(dly0-samp (delay dly0 ahead-samp))
(cur-diff (abs (- dly0-samp last-dly0-samp)))
(cur-avg (moving-average mx cur-diff))
(dly1-samp (delay dly1 ahead-samp))
- (diff-behind (abs (- dly1-samp last-dly1-samp)))
- (avg-behind (moving-average mx-behind diff-behind)))
+ (avg-behind (moving-average mx-behind (abs (- dly1-samp last-dly1-samp)))))
(set! last-ahead-samp ahead-samp)
(set! last-dly0-samp dly0-samp)
(set! last-dly1-samp dly1-samp)
@@ -401,7 +398,7 @@
(if (> pops 0)
(format () "~%; fixed ~D ~D-sample ~A" pops size (if (= pops 1) "pop" "pops"))
(quit))))
- (list 4 8 16 32))))
+ '(4 8 16 32))))
(if (= total-pops 0)
(format () "~%; no pops found")))
diff --git a/clm-ins.scm b/clm-ins.scm
index 205b986..0d05178 100644
--- a/clm-ins.scm
+++ b/clm-ins.scm
@@ -25,7 +25,7 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
(define (tuneIt f s1)
(define (getOptimumC S o p)
- (let* ((pa (* (/ 1.0 o) (atan (* S (sin o)) (+ (- 1.0 S) (* S (cos o))))))
+ (let* ((pa (* (/ 1.0 o) (atan (* S (sin o)) (- (+ 1.0 (* S (cos o))) S))))
(tmpInt (floor (- p pa)))
(pc (- p pa tmpInt)))
(if (< pc .1)
@@ -160,7 +160,7 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
(let ((evens (make-vector fs))
(odds (make-vector fs))
(ampfs (make-vector fs))
- (indices (make-float-vector fs 0.0))
+ (indices (make-float-vector fs))
(frmfs (make-vector fs))
(carrier 0.0)
(frm-int 0)
@@ -249,150 +249,149 @@ Anything other than .5 = longer decay. Must be between 0 and less than 1.0.
"(pqw-vox beg dur freq spacing-freq amp ampfun freqfun freqscl phonemes formant-amps formant-shapes) produces
vocal sounds using phase quadrature waveshaping"
- (define (vox-fun phons which newenv)
-
- (define formants
- '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
- (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
- (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
- (W 300 610 2200) (LL 380 880 2575) (R 420 1300 1600)
- (Y 300 2200 3065) (EE 260 3500 3800) (LH 280 1450 1600)
- (L 300 1300 3000) (I2 350 2300 3340) (B 200 800 1750)
- (D 300 1700 2600) (G 250 1350 2000) (M 280 900 2200)
- (N 280 1700 2600) (NG 280 2300 2750) (P 300 800 1750)
- (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
- (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
- (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
- (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400)))
- ;;formant center frequencies for a male speaker
-
- ;; make an envelope from which-th entry of phoneme data referred to by phons
- (if (null? phons)
- newenv
- (vox-fun (cddr phons) which
- (append newenv
- (list (car phons)
- ((let find-phoneme ((phoneme (cadr phons))
- (form formants))
- (if (eq? (caar form) phoneme)
- (cdar form)
- (find-phoneme phoneme (cdr form))))
- which))))))
+ (letrec ((vox-fun
+ (let ((formants '((I 390 1990 2550) (E 530 1840 2480) (AE 660 1720 2410)
+ (UH 520 1190 2390) (A 730 1090 2440) (OW 570 840 2410)
+ (U 440 1020 2240) (OO 300 870 2240) (ER 490 1350 1690)
+ (W 300 610 2200) (LL 380 880 2575) (R 420 1300 1600)
+ (Y 300 2200 3065) (EE 260 3500 3800) (LH 280 1450 1600)
+ (L 300 1300 3000) (I2 350 2300 3340) (B 200 800 1750)
+ (D 300 1700 2600) (G 250 1350 2000) (M 280 900 2200)
+ (N 280 1700 2600) (NG 280 2300 2750) (P 300 800 1750)
+ (T 200 1700 2600) (K 350 1350 2000) (F 175 900 4400)
+ (TH 200 1400 2200) (S 200 1300 2500) (SH 200 1800 2000)
+ (V 175 1100 2400) (THE 200 1600 2200)(Z 200 1300 2500)
+ (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400))))
+ ;; formant center frequencies for a male speaker
+
+ (lambda (phons which newenv)
+ ;; make an envelope from which-th entry of phoneme data referred to by phons
+ (if (null? phons)
+ newenv
+ (vox-fun (cddr phons) which
+ (append newenv
+ (list (car phons)
+ ((let find-phoneme ((phoneme (cadr phons))
+ (form formants))
+ (if (eq? (caar form) phoneme)
+ (cdar form)
+ (find-phoneme phoneme (cdr form))))
+ which)))))))))
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (car-sin (make-oscil 0))
- (car-cos (make-oscil 0 :initial-phase (/ pi 2.0)))
- (frq-ratio (/ spacing-freq freq))
- (fs (length formant-amps))
- (freqf (make-env freqfun :duration dur :scaler (* freqscl freq) :offset freq))
- (per-vib (make-triangle-wave :frequency 6.0 :amplitude (* freq .1)))
- (ran-vib (make-rand-interp :frequency 20.0 :amplitude (* freq .05))))
- (let ((sin-evens (make-vector fs))
- (cos-evens (make-vector fs))
- (sin-odds (make-vector fs))
- (cos-odds (make-vector fs))
- (ampfs (make-vector fs))
- (frmfs (make-vector fs))
- (sin-coeffs (make-vector fs))
- (cos-coeffs (make-vector fs))
- (frq 0.0) (rfrq 0.0) (carcos 0.0) (carsin 0.0)
- (frac 0.0) (fracf 0.0) (frm0 0.0) (frm-int 0) (fax 0.0) (yfax 0.0))
- (do ((i 0 (+ i 1)))
- ((= i fs))
- (let ((shape (normalize-partials (formant-shapes i))))
- (set! (sin-evens i) (make-oscil 0))
- (set! (sin-odds i) (make-oscil 0))
- (set! (cos-evens i) (make-oscil 0 :initial-phase (/ pi 2.0)))
- (set! (cos-odds i) (make-oscil 0 :initial-phase (/ pi 2.0)))
- (set! (ampfs i) (make-env ampfun :scaler (* amp (formant-amps i)) :duration dur))
- (set! (cos-coeffs i) (partials->polynomial shape mus-chebyshev-first-kind))
- (set! (sin-coeffs i) (partials->polynomial shape mus-chebyshev-second-kind))
- (set! (frmfs i) (make-env (vox-fun phonemes i ()) :duration dur))))
-
- (if (= fs 3) ; unroll the inner loop in the most common case
- (let ((frmfs0 (frmfs 0)) (frmfs1 (frmfs 1)) (frmfs2 (frmfs 2))
- (ampfs0 (ampfs 0)) (ampfs1 (ampfs 1)) (ampfs2 (ampfs 2))
- (sin-evens0 (sin-evens 0)) (sin-evens1 (sin-evens 1)) (sin-evens2 (sin-evens 2))
- (sin-odds0 (sin-odds 0)) (sin-odds1 (sin-odds 1)) (sin-odds2 (sin-odds 2))
- (cos-evens0 (cos-evens 0)) (cos-evens1 (cos-evens 1)) (cos-evens2 (cos-evens 2))
- (cos-odds0 (cos-odds 0)) (cos-odds1 (cos-odds 1)) (cos-odds2 (cos-odds 2))
- (cos-coeffs0 (cos-coeffs 0)) (cos-coeffs1 (cos-coeffs 1)) (cos-coeffs2 (cos-coeffs 2))
- (sin-coeffs0 (sin-coeffs 0)) (sin-coeffs1 (sin-coeffs 1)) (sin-coeffs2 (sin-coeffs 2)))
+ (let ((start (seconds->samples beg))
+ (end (seconds->samples (+ beg dur)))
+ (car-sin (make-oscil 0))
+ (car-cos (make-oscil 0 :initial-phase (/ pi 2.0)))
+ (frq-ratio (/ spacing-freq freq))
+ (fs (length formant-amps))
+ (freqf (make-env freqfun :duration dur :scaler (* freqscl freq) :offset freq))
+ (per-vib (make-triangle-wave :frequency 6.0 :amplitude (* freq .1)))
+ (ran-vib (make-rand-interp :frequency 20.0 :amplitude (* freq .05))))
+ (let ((sin-evens (make-vector fs))
+ (cos-evens (make-vector fs))
+ (sin-odds (make-vector fs))
+ (cos-odds (make-vector fs))
+ (ampfs (make-vector fs))
+ (frmfs (make-vector fs))
+ (sin-coeffs (make-vector fs))
+ (cos-coeffs (make-vector fs))
+ (frq 0.0) (rfrq 0.0) (carcos 0.0) (carsin 0.0)
+ (frac 0.0) (fracf 0.0) (frm0 0.0) (frm-int 0) (fax 0.0) (yfax 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i fs))
+ (let ((shape (normalize-partials (formant-shapes i))))
+ (set! (sin-evens i) (make-oscil 0))
+ (set! (sin-odds i) (make-oscil 0))
+ (set! (cos-evens i) (make-oscil 0 :initial-phase (/ pi 2.0)))
+ (set! (cos-odds i) (make-oscil 0 :initial-phase (/ pi 2.0)))
+ (set! (ampfs i) (make-env ampfun :scaler (* amp (formant-amps i)) :duration dur))
+ (set! (cos-coeffs i) (partials->polynomial shape mus-chebyshev-first-kind))
+ (set! (sin-coeffs i) (partials->polynomial shape mus-chebyshev-second-kind))
+ (set! (frmfs i) (make-env (vox-fun phonemes i ()) :duration dur))))
+
+ (if (= fs 3) ; unroll the inner loop in the most common case
+ (let ((frmfs0 (frmfs 0)) (frmfs1 (frmfs 1)) (frmfs2 (frmfs 2))
+ (ampfs0 (ampfs 0)) (ampfs1 (ampfs 1)) (ampfs2 (ampfs 2))
+ (sin-evens0 (sin-evens 0)) (sin-evens1 (sin-evens 1)) (sin-evens2 (sin-evens 2))
+ (sin-odds0 (sin-odds 0)) (sin-odds1 (sin-odds 1)) (sin-odds2 (sin-odds 2))
+ (cos-evens0 (cos-evens 0)) (cos-evens1 (cos-evens 1)) (cos-evens2 (cos-evens 2))
+ (cos-odds0 (cos-odds 0)) (cos-odds1 (cos-odds 1)) (cos-odds2 (cos-odds 2))
+ (cos-coeffs0 (cos-coeffs 0)) (cos-coeffs1 (cos-coeffs 1)) (cos-coeffs2 (cos-coeffs 2))
+ (sin-coeffs0 (sin-coeffs 0)) (sin-coeffs1 (sin-coeffs 1)) (sin-coeffs2 (sin-coeffs 2)))
+ (do ((i start (+ i 1)))
+ ((= i end))
+ (set! frq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
+ (set! rfrq (hz->radians frq))
+ (set! carsin (oscil car-sin (* rfrq frq-ratio)))
+ (set! carcos (oscil car-cos (* rfrq frq-ratio)))
+
+ (set! frm0 (/ (env frmfs0) frq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (* frm-int rfrq))
+ (set! fax (polynomial cos-coeffs0 carcos))
+ (set! yfax (* carsin (polynomial sin-coeffs0 carcos)))
+ (outa i
+ (* (env ampfs0)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens0 fracf)) (* fax (oscil cos-evens0 fracf))))
+ (* frac (- (* yfax (oscil sin-odds0 (+ fracf rfrq))) (* fax (oscil cos-odds0 (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil sin-evens0 (+ fracf rfrq))) (* fax (oscil cos-evens0 (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil sin-odds0 fracf)) (* fax (oscil cos-odds0 fracf))))))))
+
+ (set! frm0 (/ (env frmfs1) frq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (* frm-int rfrq))
+ (set! fax (polynomial cos-coeffs1 carcos))
+ (set! yfax (* carsin (polynomial sin-coeffs1 carcos)))
+ (outa i
+ (* (env ampfs1)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens1 fracf)) (* fax (oscil cos-evens1 fracf))))
+ (* frac (- (* yfax (oscil sin-odds1 (+ fracf rfrq))) (* fax (oscil cos-odds1 (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil sin-evens1 (+ fracf rfrq))) (* fax (oscil cos-evens1 (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil sin-odds1 fracf)) (* fax (oscil cos-odds1 fracf))))))))
+
+ (set! frm0 (/ (env frmfs2) frq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (* frm-int rfrq))
+ (set! fax (polynomial cos-coeffs2 carcos))
+ (set! yfax (* carsin (polynomial sin-coeffs2 carcos)))
+ (outa i
+ (* (env ampfs2)
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens2 fracf)) (* fax (oscil cos-evens2 fracf))))
+ (* frac (- (* yfax (oscil sin-odds2 (+ fracf rfrq))) (* fax (oscil cos-odds2 (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil sin-evens2 (+ fracf rfrq))) (* fax (oscil cos-evens2 (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil sin-odds2 fracf)) (* fax (oscil cos-odds2 fracf))))))))))
+
(do ((i start (+ i 1)))
((= i end))
(set! frq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
(set! rfrq (hz->radians frq))
(set! carsin (oscil car-sin (* rfrq frq-ratio)))
(set! carcos (oscil car-cos (* rfrq frq-ratio)))
-
- (set! frm0 (/ (env frmfs0) frq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (* frm-int rfrq))
- (set! fax (polynomial cos-coeffs0 carcos))
- (set! yfax (* carsin (polynomial sin-coeffs0 carcos)))
- (outa i
- (* (env ampfs0)
- (if (even? frm-int)
- (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens0 fracf)) (* fax (oscil cos-evens0 fracf))))
- (* frac (- (* yfax (oscil sin-odds0 (+ fracf rfrq))) (* fax (oscil cos-odds0 (+ fracf rfrq))))))
- (+ (* frac (- (* yfax (oscil sin-evens0 (+ fracf rfrq))) (* fax (oscil cos-evens0 (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil sin-odds0 fracf)) (* fax (oscil cos-odds0 fracf))))))))
-
- (set! frm0 (/ (env frmfs1) frq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (* frm-int rfrq))
- (set! fax (polynomial cos-coeffs1 carcos))
- (set! yfax (* carsin (polynomial sin-coeffs1 carcos)))
- (outa i
- (* (env ampfs1)
- (if (even? frm-int)
- (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens1 fracf)) (* fax (oscil cos-evens1 fracf))))
- (* frac (- (* yfax (oscil sin-odds1 (+ fracf rfrq))) (* fax (oscil cos-odds1 (+ fracf rfrq))))))
- (+ (* frac (- (* yfax (oscil sin-evens1 (+ fracf rfrq))) (* fax (oscil cos-evens1 (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil sin-odds1 fracf)) (* fax (oscil cos-odds1 fracf))))))))
-
- (set! frm0 (/ (env frmfs2) frq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (* frm-int rfrq))
- (set! fax (polynomial cos-coeffs2 carcos))
- (set! yfax (* carsin (polynomial sin-coeffs2 carcos)))
- (outa i
- (* (env ampfs2)
- (if (even? frm-int)
- (+ (* (- 1.0 frac) (- (* yfax (oscil sin-evens2 fracf)) (* fax (oscil cos-evens2 fracf))))
- (* frac (- (* yfax (oscil sin-odds2 (+ fracf rfrq))) (* fax (oscil cos-odds2 (+ fracf rfrq))))))
- (+ (* frac (- (* yfax (oscil sin-evens2 (+ fracf rfrq))) (* fax (oscil cos-evens2 (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil sin-odds2 fracf)) (* fax (oscil cos-odds2 fracf))))))))))
-
- (do ((i start (+ i 1)))
- ((= i end))
- (set! frq (+ (env freqf) (triangle-wave per-vib) (rand-interp ran-vib)))
- (set! rfrq (hz->radians frq))
- (set! carsin (oscil car-sin (* rfrq frq-ratio)))
- (set! carcos (oscil car-cos (* rfrq frq-ratio)))
- (do ((k 0 (+ k 1)))
- ((= k fs))
- (set! frm0 (/ (env (vector-ref frmfs k)) frq))
- (set! frm-int (floor frm0))
- (set! frac (- frm0 frm-int))
- (set! fracf (* frm-int rfrq))
- (set! fax (polynomial (vector-ref cos-coeffs k) carcos))
- (set! yfax (* carsin (polynomial (vector-ref sin-coeffs k) carcos)))
- (outa i (* (env (vector-ref ampfs k))
- (if (even? frm-int)
- (+ (* (- 1.0 frac) (- (* yfax (oscil (vector-ref sin-evens k) fracf))
- (* fax (oscil (vector-ref cos-evens k) fracf))))
- (* frac (- (* yfax (oscil (vector-ref sin-odds k) (+ fracf rfrq)))
- (* fax (oscil (vector-ref cos-odds k) (+ fracf rfrq))))))
- (+ (* frac (- (* yfax (oscil (vector-ref sin-evens k) (+ fracf rfrq)))
- (* fax (oscil (vector-ref cos-evens k) (+ fracf rfrq)))))
- (* (- 1.0 frac) (- (* yfax (oscil (vector-ref sin-odds k) fracf))
- (* fax (oscil (vector-ref cos-odds k) fracf))))))))))))))
-
+ (do ((k 0 (+ k 1)))
+ ((= k fs))
+ (set! frm0 (/ (env (vector-ref frmfs k)) frq))
+ (set! frm-int (floor frm0))
+ (set! frac (- frm0 frm-int))
+ (set! fracf (* frm-int rfrq))
+ (set! fax (polynomial (vector-ref cos-coeffs k) carcos))
+ (set! yfax (* carsin (polynomial (vector-ref sin-coeffs k) carcos)))
+ (outa i (* (env (vector-ref ampfs k))
+ (if (even? frm-int)
+ (+ (* (- 1.0 frac) (- (* yfax (oscil (vector-ref sin-evens k) fracf))
+ (* fax (oscil (vector-ref cos-evens k) fracf))))
+ (* frac (- (* yfax (oscil (vector-ref sin-odds k) (+ fracf rfrq)))
+ (* fax (oscil (vector-ref cos-odds k) (+ fracf rfrq))))))
+ (+ (* frac (- (* yfax (oscil (vector-ref sin-evens k) (+ fracf rfrq)))
+ (* fax (oscil (vector-ref cos-evens k) (+ fracf rfrq)))))
+ (* (- 1.0 frac) (- (* yfax (oscil (vector-ref sin-odds k) fracf))
+ (* fax (oscil (vector-ref cos-odds k) fracf)))))))))))))))
+
;;; (with-sound (:statistics #t) (pqw-vox 0 1 300 300 .1 '(0 0 50 1 100 0) '(0 0 100 0) 0 '(0 L 100 L) '(.33 .33 .33) '((1 1 2 .5) (1 .5 2 .5 3 1) (1 1 4 .5))))
;;; (a test to see if the cancellation is working -- sounds like a mosquito)
@@ -412,7 +411,7 @@ synthesis: (fofins 0 1 270 .2 .001 730 .6 1090 .3 2440 .1)"
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(ampf (make-env ae :scaler amp :duration dur))
- (vibf (make-env (or ve (list 0 1 100 1)) :scaler vib :duration dur))
+ (vibf (make-env (or ve '(0 1 100 1)) :scaler vib :duration dur))
(frq0 (hz->radians f0))
(frq1 (hz->radians f1))
(frq2 (hz->radians f2))
@@ -472,16 +471,16 @@ synthesis: (fofins 0 1 270 .2 .001 730 .6 1090 .3 2440 .1)"
(let ((beg (seconds->samples startime))
(end (seconds->samples (+ startime dur)))
(loc (make-locsig degree distance reverb-amount))
- (per-vib-f (make-env (stretch-envelope '(0 1 25 .1 75 0 100 0)
- 25 (min (* 100 (/ vibatt dur)) 45)
- 75 (max (* 100 (- 1.0 (/ vibdec dur))) 55))
- :scaler vibamp :duration dur))
+ (per-vib-f (let ((vibe (stretch-envelope '(0 1 25 .1 75 0 100 0)
+ 25 (min (* 100 (/ vibatt dur)) 45)
+ 75 (max (* 100 (- 1.0 (/ vibdec dur))) 55))))
+ (make-env vibe :scaler vibamp :duration dur)))
(ran-vib (make-rand-interp :frequency rvibfrq :amplitude rvibamp))
(per-vib (make-oscil vibfrq))
- (frq-f (make-env (stretch-envelope '(0 0 25 1 75 1 100 0)
- 25 (min 25 (* 100 (/ frqatt dur)))
- 75 dec-01)
- :scaler frqskw :offset 1.0 :duration dur))
+ (frq-f (let ((frqe (stretch-envelope '(0 0 25 1 75 1 100 0)
+ 25 (min 25 (* 100 (/ frqatt dur)))
+ 75 dec-01)))
+ (make-env frqe :scaler frqskw :offset 1.0 :duration dur)))
(ampattpt1 (min 25 (* 100 (/ ampatt1 dur))))
(ampdecpt1 (max 75 (* 100 (- 1.0 (/ ampdec1 dur)))))
(ampattpt2 (min 25 (* 100 (/ ampatt2 dur))))
@@ -584,8 +583,8 @@ is a physical model of a flute:
(set! tap-sig (tap bore offset))
;; NB the DC blocker is not in the cicuit. It is applied to the out-sig
;; but the result is not fed back into the system.
- (set! dc-blocked-a (+ (- out-sig previous-out-sig) (* 0.995 previous-dc-blocked-a)))
- (set! dc-blocked-b (+ (- tap-sig previous-tap-sig) (* 0.995 previous-dc-blocked-b)))
+ (set! dc-blocked-a (- (+ out-sig (* 0.995 previous-dc-blocked-a)) previous-out-sig))
+ (set! dc-blocked-b (- (+ tap-sig (* 0.995 previous-dc-blocked-b)) previous-tap-sig))
(outa i (* out-scl dc-blocked-a))
(outb i (* out-scl dc-blocked-b))
(set! previous-out-sig out-sig)
@@ -613,10 +612,10 @@ is a physical model of a flute:
(car2 (make-oscil frequency))
(car3 (make-oscil (* frequency 2.4)))
(indf (make-env (or index-env
- (list 0 1 2 1.1 25 .75 75 .5 100 .2))
+ '(0 1 2 1.1 25 .75 75 .5 100 .2))
(or index 1.0) dur))
(ampf (make-env (or amp-env
- (list 0 0 .1 1 10 .6 25 .3 50 .15 90 .1 100 0))
+ '(0 0 .1 1 10 .6 25 .3 50 .15 90 .1 100 0))
amplitude dur)))
(do ((i beg (+ i 1)))
((= i end))
@@ -699,18 +698,18 @@ is a physical model of a flute:
(let ((beg (seconds->samples start-time))
(end (seconds->samples (+ start-time duration)))
(glsf (make-env glsfun :scaler (if high (hz->radians 66) 0.0) :duration duration))
- (ampf (make-env (stretch-envelope ampfun
- 10 atdrpt
- 15 (max (+ atdrpt 1)
- (- 100 (* 100 (/ (- duration .2) duration)))))
- :scaler amplitude :duration duration))
+ (ampf (let ((ampe (stretch-envelope ampfun
+ 10 atdrpt
+ 15 (max (+ atdrpt 1)
+ (- 100 (* 100 (/ (- duration .2) duration)))))))
+ (make-env ampe :scaler amplitude :duration duration)))
(indxf (make-env divindxf :scaler (min (hz->radians (* index fmrat frequency)) pi) :duration duration))
(mindxf (make-env divindxf :scaler (min (hz->radians (* index casrat frequency)) pi) :duration duration))
- (devf (make-env (stretch-envelope ampfun
- 10 atdrpt
- 90 (max (+ atdrpt 1)
- (- 100 (* 100 (/ (- duration .05) duration)))))
- :scaler (min pi (hz->radians 7000)) :duration duration))
+ (devf (let ((deve (stretch-envelope ampfun
+ 10 atdrpt
+ 90 (max (+ atdrpt 1)
+ (- 100 (* 100 (/ (- duration .05) duration)))))))
+ (make-env deve :scaler (min pi (hz->radians 7000)) :duration duration)))
(loc (make-locsig degree distance reverb-amount))
(rn (make-rand :frequency 7000 :amplitude 1.0))
(carrier (make-oscil frequency))
@@ -945,15 +944,14 @@ is a physical model of a flute:
(definstrument (drone startime dur frequency amp ampfun synth ampat ampdc amtrev deg dis rvibamt rvibfreq)
(let ((beg (seconds->samples startime))
- (end (seconds->samples (+ startime dur)))
- (waveform (partials->wave synth))
- (amplitude (* amp .25))
- (freq (hz->radians frequency)))
+ (end (seconds->samples (+ startime dur)))
+ (waveform (partials->wave synth))
+ (amplitude (* amp .25))
+ (freq (hz->radians frequency)))
(let ((s (make-table-lookup :frequency frequency :wave waveform))
- (amp-env (make-env (stretch-envelope ampfun 25 (* 100 (/ ampat dur)) 75 (- 100 (* 100 (/ ampdc dur))))
- :scaler amplitude :duration dur))
- (ran-vib (make-rand :frequency rvibfreq
- :amplitude (* rvibamt freq)))
+ (amp-env (let ((ampe (stretch-envelope ampfun 25 (* 100 (/ ampat dur)) 75 (- 100 (* 100 (/ ampdc dur))))))
+ (make-env ampe :scaler amplitude :duration dur)))
+ (ran-vib (make-rand :frequency rvibfreq :amplitude (* rvibamt freq)))
(loc (make-locsig deg dis amtrev)))
(do ((i beg (+ i 1)))
((= i end))
@@ -1084,20 +1082,22 @@ is a physical model of a flute:
vibfreq vibpc ranvibfreq ranvibpc degree distance reverb-amount data)
;; data is a list of lists of form '(ampf resonfrq resonamp ampat ampdc dev0 dev1 indxat indxdc)
(let ((beg (seconds->samples startime))
- (end (seconds->samples (+ startime dur)))
- (carriers (make-vector numformants))
- (modulator (make-oscil pitch))
- (ampfs (make-vector numformants))
- (indfs (make-vector numformants))
- (c-rats (make-vector numformants))
- (frqf (make-env (stretch-envelope skewfun 25 (* 100 (/ skewat dur)) 75 (- 100 (* 100 (/ skewdc dur))))
- :scaler (hz->radians (* pcskew pitch)) :duration dur))
- (totalamp 0.0)
- (loc (make-locsig degree distance reverb-amount))
- (pervib (make-triangle-wave :frequency vibfreq
- :amplitude (hz->radians (* vibpc pitch))))
- (ranvib (make-rand-interp :frequency ranvibfreq
- :amplitude (hz->radians (* ranvibpc pitch)))))
+ (end (seconds->samples (+ startime dur)))
+ (carriers (make-vector numformants))
+ (modulator (make-oscil pitch))
+ (ampfs (make-vector numformants))
+ (indfs (make-vector numformants))
+ (c-rats (make-vector numformants))
+ (totalamp 0.0)
+ (loc (make-locsig degree distance reverb-amount))
+ (pervib (make-triangle-wave :frequency vibfreq
+ :amplitude (hz->radians (* vibpc pitch))))
+ (ranvib (make-rand-interp :frequency ranvibfreq
+ :amplitude (hz->radians (* ranvibpc pitch))))
+ (frqf (let ((frqe (stretch-envelope skewfun
+ 25 (* 100 (/ skewat dur))
+ 75 (- 100 (* 100 (/ skewdc dur))))))
+ (make-env frqe :scaler (hz->radians (* pcskew pitch)) :duration dur))))
;; initialize the "formant" generators
(do ((i 0 (+ i 1)))
((= i numformants))
@@ -1122,9 +1122,9 @@ is a physical model of a flute:
(if (zero? indxat) (set! indxat 25))
(if (zero? indxdc) (set! indxdc 75))
(set! (indfs i) (make-env (stretch-envelope indxfun 25 indxat 75 indxdc) :duration dur
- :scaler (- dev1 dev0) :offset dev0))
+ :scaler (- dev1 dev0) :offset dev0))
(set! (ampfs i) (make-env (stretch-envelope ampf 25 ampat 75 ampdc) :duration dur
- :scaler (/ (* rsamp amp rfamp) totalamp)))
+ :scaler (/ (* rsamp amp rfamp) totalamp)))
(set! (c-rats i) harm)
(set! (carriers i) (make-oscil cfq))))
(if (= numformants 2)
@@ -1784,7 +1784,7 @@ is a physical model of a flute:
(siz (floor (/ (length partials) 2))))
(let ((env1samples (+ beg (seconds->samples env1dur)))
(freqs (make-float-vector siz))
- (phases (make-float-vector siz 0.0))
+ (phases (make-float-vector siz))
(alist (make-float-vector siz))
(locs (make-locsig degree distance reverb-amount))
(ampfun1 (make-piano-ampfun env1dur)))
@@ -1953,16 +1953,16 @@ is a physical model of a flute:
(fdr (make-float-vector fftsize-1))
(fdi (make-float-vector fftsize-1))
(window (make-fft-window blackman2-window fftsize-1))
- (current-peak-freqs (make-float-vector max-oscils 0.0))
- (last-peak-freqs (make-float-vector max-oscils 0.0))
- (current-peak-amps (make-float-vector max-oscils 0.0))
- (last-peak-amps (make-float-vector max-oscils 0.0))
- (peak-amps (make-float-vector max-peaks-1 0.0))
- (peak-freqs (make-float-vector max-peaks-1 0.0))
- (amps (make-float-vector max-oscils 0.0)) ;run-time generated amplitude and frequency envelopes
- (rates (make-float-vector max-oscils 0.0))
- (freqs (make-float-vector max-oscils 0.0))
- (sweeps (make-float-vector max-oscils 0.0))
+ (current-peak-freqs (make-float-vector max-oscils))
+ (last-peak-freqs (make-float-vector max-oscils))
+ (current-peak-amps (make-float-vector max-oscils))
+ (last-peak-amps (make-float-vector max-oscils))
+ (peak-amps (make-float-vector max-peaks-1))
+ (peak-freqs (make-float-vector max-peaks-1))
+ (amps (make-float-vector max-oscils)) ;run-time generated amplitude and frequency envelopes
+ (rates (make-float-vector max-oscils))
+ (freqs (make-float-vector max-oscils))
+ (sweeps (make-float-vector max-oscils))
;; (lowest-magnitude .001)
(ihifreq (hz->radians ifreq))
@@ -1973,8 +1973,8 @@ is a physical model of a flute:
(filend 0)
(cur-oscils max-oscils)
(splice-attack (number? attack))
- (ramped-attack (make-float-vector attack-size 0.0)))
- (let ((obank (make-oscil-bank freqs (make-float-vector max-oscils 0.0) amps)))
+ (ramped-attack (make-float-vector attack-size)))
+ (let ((obank (make-oscil-bank freqs (make-float-vector max-oscils) amps)))
(set! filend (mus-length fil))
(float-vector-scale! window fftscale)
@@ -2247,7 +2247,7 @@ is a physical model of a flute:
hop
(list 0 hop 1 hop))
:duration dur))
- (ampe (make-env (or ampenv (list 0 0 .5 1 1 0)) :scaler amp :duration dur)))
+ (ampe (make-env (or ampenv '(0 0 .5 1 1 0)) :scaler amp :duration dur)))
(let ((exA (make-granulate :expansion initial-exp-amt
:input f0
:max-size max-len
@@ -2502,7 +2502,7 @@ nil doesnt print anything, which will speed up a bit the process.
(fdr (make-float-vector fftsize)))
(let ((spectr (make-vector freq-inc 1.0))
(scales (make-float-vector freq-inc 1.0))
- (diffs (make-float-vector freq-inc 0.0))
+ (diffs (make-float-vector freq-inc))
(win (make-fft-window blackman2-window fftsize))
(k 0)
(amp 0.0)
@@ -2705,7 +2705,7 @@ mjkoskin at sci.fi
(> (mus-sound-chans impulse) 1)
(make-float-vector filter-len))))
(file->array impulse 0 0 filter-len filter-chan0)
- (if filter-chan1
+ (if (float-vector? filter-chan1)
(file->array impulse 1 0 filter-len filter-chan1)
(set! filter-chan1 filter-chan0))
(let ((fd (make-readin file))
diff --git a/clm.c b/clm.c
index 350e6e6..ed3070d 100644
--- a/clm.c
+++ b/clm.c
@@ -1720,7 +1720,7 @@ mus_float_t mus_ncos(mus_any *ptr, mus_float_t fm)
(+ 1 (* n 2)))))
(with-sound (:scaled-to 1.0)
- (do ((i 0 (1+ i))
+ (do ((i 0 (+ i 1))
(x 0.0 (+ x .01)))
((= i 200)) ; glitch at 100 (= 1)
(outa i (ncos-with-inversions 1 (* pi x)) *output*)))
@@ -1886,11 +1886,11 @@ bool mus_is_nsin(mus_any *ptr)
(define (smax coeffs)
(let* ((n (vct-length coeffs))
(dcos (make-vct n 1.0)))
- (do ((i 0 (1+ i)))
+ (do ((i 0 (+ i 1)))
((= i n))
(vct-set! dcos i (* (+ i 1) (vct-ref coeffs i))))
(let ((partials ()))
- (do ((i 0 (1+ i)))
+ (do ((i 0 (+ i 1)))
((= i n))
(set! partials (append (list (vct-ref dcos i) (+ i 1)) partials)))
(let ((Tn (partials->polynomial (reverse partials))))
@@ -1900,7 +1900,7 @@ bool mus_is_nsin(mus_any *ptr)
(lambda (root)
(let ((acr (acos root))
(sum 0.0))
- (do ((i 0 (1+ i)))
+ (do ((i 0 (+ i 1)))
((= i n))
(set! sum (+ sum (* (vct-ref coeffs i) (sin (* (+ i 1) acr))))))
(if (> (abs sum) mx)
@@ -1920,7 +1920,7 @@ bool mus_is_nsin(mus_any *ptr)
(den (sin a2)))
(if (= den 0.0)
0.0
- (/ (* (sin (* n a2)) (sin (* (1+ n) a2))) den))))
+ (/ (* (sin (* n a2)) (sin (* (+ n 1) a2))) den))))
(define (find-mid-max n lo hi)
(let ((mid (/ (+ lo hi) 2)))
@@ -2008,7 +2008,7 @@ mus_float_t mus_nsin(mus_any *ptr, mus_float_t fm)
(den (sin a2)))
(if (= den 0.0)
0.0
- (/ (* (sin (* n a2)) (sin (* (1+ n) a2))) den)))
+ (/ (* (sin (* n a2)) (sin (* (+ n 1) a2))) den)))
*/
#if HAVE_SINCOS
double val, a2, ns, nc, s, c;
@@ -3317,7 +3317,7 @@ mus_float_t mus_chebyshev_t_sum(mus_float_t x, int n, mus_float_t *tn)
(let ((t2n (vct 0.5 0.25 0.25))
(x 0.0)
(dx (hz->radians 10.0)))
- (do ((i 0 (1+ i)))
+ (do ((i 0 (+ i 1)))
((= i 22050))
(outa i (mus-chebyshev-odd-t-sum x 3 t2n))
(set! x (+ x dx)))))
@@ -9393,7 +9393,7 @@ typedef struct {
(cf (exp (/ (- le ls) (1- num))))
(max-diff 0.0)
(xstart start))
- (do ((i 0 (1+ i)))
+ (do ((i 0 (+ i 1)))
((= i num)
max-diff)
(let ((val1 (* start (exp (* (/ i (1- num)) (- le ls)))))
diff --git a/clm23.scm b/clm23.scm
index a225004..99fed8f 100644
--- a/clm23.scm
+++ b/clm23.scm
@@ -40,9 +40,6 @@
(sin (phases i))))))
sum))
-
-(define open-input make-file->sample)
-
(define two-pi (* 2 pi))
(define (simple-out beg dur freq amp)
@@ -137,14 +134,12 @@
(define (simple-osc beg dur freq amp)
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
- (freqs (make-float-vector 20)))
- (let ((obank (make-oscil-bank freqs
- (let ((fv (make-float-vector 20 0.0)))
- (do ((i 0 (+ i 1)))
- ((= i 20) fv)
- (set! (freqs i) (hz->radians (* (+ i 1) 100)))))
- (make-float-vector 20 1.0)
- #t)))
+ (freqs (make-float-vector 20))
+ (fv (make-float-vector 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (set! (freqs i) (hz->radians (* (+ i 1) freq))))
+ (let ((obank (make-oscil-bank freqs fv (make-float-vector 20 1.0) #t)))
(set! amp (* 0.05 amp))
(do ((i start (+ i 1)))
((= i end))
@@ -397,12 +392,12 @@
(let ((foflen (if (= *clm-srate* 22050) 100 200)))
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
- (ampf (make-env :envelope (or ae (list 0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
+ (ampf (make-env :envelope (or ae '(0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(frq0 (hz->radians f0))
(frq1 (hz->radians f1))
(frq2 (hz->radians f2))
(vibr (make-oscil 6))
- (vibenv (make-env :envelope (or ve (list 0 1 100 1)) :scaler vib :duration dur))
+ (vibenv (make-env :envelope (or ve '(0 1 100 1)) :scaler vib :duration dur))
(win-freq (/ two-pi foflen))
(wt0 (make-wave-train :size foflen :frequency frq)))
(let ((foftab (mus-data wt0)))
@@ -416,7 +411,7 @@
(outa i (* (env ampf) (wave-train wt0 (* (env vibenv) (oscil vibr)))))))))
(define (simple-amb beg dur freq amp)
- (let ((os (if (> freq 1) (make-oscil freq) (make-rand freq)))
+ (let ((os ((if (> freq 1) make-oscil make-rand) freq))
(start (seconds->samples beg))
(end (seconds->samples (+ beg dur))))
(do ((i start (+ i 1))) ((= i end))
@@ -534,7 +529,7 @@
(define (simple-ina beg dur amp file)
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
- (fil (open-input file)))
+ (fil (make-file->sample file)))
(do ((i start (+ i 1))
(ctr 0 (+ ctr 1)))
((= i end))
@@ -864,10 +859,10 @@
(format () "~A ~A~%" (xs 1) (mus-xcoeff flt 1))))
(let ((data (mus-data flt)))
(if (> (data 0) 1.0) (format () "data overflow? ~A~%" (data 0))))
- (let ((is intdat)
- (fs fltdat))
- (if (not (= (is 1) 3)) (format () "intdat let: ~A~%" (is 1)))
- (if (> (abs (- (fs 1) 3.14)) .001) (format () "fltdat let: ~A~%" (fs 1))))
+ (if (not (= (intdat 1) 3))
+ (format () "intdat let: ~A~%" (intdat 1)))
+ (if (> (abs (- (fltdat 1) 3.14)) 0.001)
+ (format () "fltdat let: ~A~%" (fltdat 1)))
(outa i (* amp (filter flt (oscil os)))))))
(define (sample-arrintp beg dur freq amp)
@@ -1125,8 +1120,7 @@
(modulator-phase-incr (hz->radians (* mc-ratio freq))))
(do ((i beg (+ i 1)))
((= i end))
- (let* ((modulation (* index (sin modulator-phase)))
- (pm-val (* amp (sin (+ carrier-phase modulation)))))
+ (let ((pm-val (* amp (sin (+ carrier-phase (* index (sin modulator-phase)))))))
;; no integration in phase modulation (it's a phase change)
(set! carrier-phase (+ carrier-phase carrier-phase-incr))
(set! modulator-phase (+ modulator-phase modulator-phase-incr))
@@ -1221,7 +1215,7 @@
((= i n))
(set! (modulators i) (hz->radians (* freq (mc-ratios i) (mod-phases i))))
(set! (fm-indices i) (hz->radians (* freq (indexes i) (mc-ratios i)))))
- (let ((ob (make-oscil-bank modulators (make-float-vector n 0.0) fm-indices #t)))
+ (let ((ob (make-oscil-bank modulators (make-float-vector n) fm-indices #t)))
(do ((i start (+ i 1)))
((= i end))
(outa i (* amp (oscil cr (oscil-bank ob))))))))))
@@ -1233,7 +1227,7 @@
(frq-scl (hz->radians frequency)))
(let ((maxdev (* frq-scl fm-index)))
(let ((index1 (* maxdev (/ 5.0 (log frequency))))
- (index2 (* maxdev 3.0 (/ (- 8.5 (log frequency)) (+ 3.0 (/ frequency 1000)))))
+ (index2 (/ (* maxdev 3.0 (- 8.5 (log frequency))) (+ 3.0 (/ frequency 1000))))
(index3 (* maxdev (/ 4.0 (sqrt frequency))))
(carrier (make-oscil frequency))
(fmosc1 (make-oscil frequency))
@@ -1262,7 +1256,7 @@
(md (make-oscil (* freq modrat)))
(ca (make-oscil (* freq casrat) caspha))
(fm-ind0 (hz->radians (* modind modrat freq)))
- (fm-ind1 (hz->radians (* casind (/ casrat modrat) freq))))
+ (fm-ind1 (hz->radians (/ (* casind casrat freq) modrat))))
(do ((i start (+ i 1)))
((= i end))
(outa i (* amp
@@ -1474,11 +1468,10 @@
(<= (cadr loop-data) (car loop-data)))
(error 'no-loop-positions)
(let* ((loop-start (car loop-data))
- (loop-end (cadr loop-data))
- (loop-length (+ 1 (- loop-end loop-start)))
+ (loop-length (- (+ (cadr loop-data) 1) loop-start))
(sound-section (float-vector-scale! (file->array sound 0 loop-start loop-length (make-float-vector loop-length)) amp))
- (original-loop-duration (/ loop-length (srate sound)))
- (tbl (make-table-lookup :frequency (/ freq original-loop-duration) :wave sound-section)))
+ (tbl (make-table-lookup :frequency (/ (* freq (srate sound)) loop-length)
+ :wave sound-section)))
;; "freq" here is how fast we read (transpose) the sound -- 1.0 returns the original
(do ((i beg (+ i 1)))
((= i end))
@@ -1585,8 +1578,7 @@
(float-vector 0.0 (hz->radians frequency) (* 1.0 n)))
(define (sndclmdoc-sum-of-odd-sines gen fm)
- (let* ((angle (gen 0))
- (a2 (* angle 0.5))
+ (let* ((a2 (* (gen 0) 0.5))
(n (gen 2))
(den (* n (sin a2)))
(result (if (< (abs den) 1.0e-9)
@@ -1650,12 +1642,12 @@
(let ((foftab (make-float-vector foflen)))
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
- (ampf (make-env :envelope (or ae (list 0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
+ (ampf (make-env :envelope (or ae '(0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(frq0 (hz->radians f0))
(frq1 (hz->radians f1))
(frq2 (hz->radians f2))
(vibr (make-oscil 6))
- (vibenv (make-env :envelope (or ve (list 0 1 100 1)) :scaler vib :duration dur))
+ (vibenv (make-env :envelope (or ve '(0 1 100 1)) :scaler vib :duration dur))
(win-freq (/ (* 2 pi) foflen))
(wt0 (make-wave-train :wave foftab :frequency frq)))
(do ((i 0 (+ i 1)))
@@ -1743,11 +1735,9 @@
(outa i (convolve ff)))))
(definstrument (sndclmdoc-granulate-sound file beg dur (orig-beg 0.0) (exp-amt 1.0))
- (let* ((f-srate (srate file))
- (f-start (round (* f-srate orig-beg)))
- (f (make-readin file :start f-start))
- (st (seconds->samples beg))
- (new-dur (or dur (- (mus-sound-duration file) orig-beg))))
+ (let ((f (make-readin file :start (round (* (srate file) orig-beg))))
+ (st (seconds->samples beg))
+ (new-dur (or dur (- (mus-sound-duration file) orig-beg))))
(let ((exA (make-granulate :input f :expansion exp-amt))
(nd (+ st (seconds->samples new-dur))))
(do ((i st (+ i 1)))
diff --git a/clm2xen.c b/clm2xen.c
index a8e00e1..87debfa 100644
--- a/clm2xen.c
+++ b/clm2xen.c
@@ -2487,7 +2487,7 @@ static Xen g_make_oscil(Xen arg1, Xen arg2, Xen arg3, Xen arg4)
static Xen g_oscil(Xen osc, Xen fm, Xen pm)
{
#define H_oscil "(" S_oscil " gen (fm 0.0) (pm 0.0)): next sample from " S_oscil " gen: val = sin(phase + pm); phase += (freq + fm)"
- #define Q_oscil s7_make_circular_signature(s7, 2, 3, s7_make_symbol(s7, "float?"), s7_make_symbol(s7, "oscil?"), s7_make_symbol(s7, "real?"))
+ #define Q_oscil s7_make_circular_signature(s7, 2, 3, s7_make_symbol(s7, "float?"), s7_make_symbol(s7, S_is_oscil), s7_make_symbol(s7, "real?"))
mus_float_t fm1;
mus_any *g = NULL;
@@ -4930,7 +4930,7 @@ static Xen g_singer_filter(Xen start, Xen end, Xen tmp, Xen dline1, Xen dline2,
#define H_singer_filter "this is an optimization for the singer instrument"
int j, k, beg, lim;
s7_double *d1, *d2, *cf;
- s7_double temp, x;
+ s7_double temp;
if (!s7_is_integer(start)) s7_wrong_type_arg_error(s7, S_singer_filter, 1, start, "an integer");
if (!s7_is_integer(end)) s7_wrong_type_arg_error(s7, S_singer_filter, 2, end, "an integer");
@@ -4939,7 +4939,6 @@ static Xen g_singer_filter(Xen start, Xen end, Xen tmp, Xen dline1, Xen dline2,
if (!s7_is_float_vector(dline2)) s7_wrong_type_arg_error(s7, S_singer_filter, 5, dline2, "a float-vector");
if (!s7_is_float_vector(coeffs)) s7_wrong_type_arg_error(s7, S_singer_filter, 6, coeffs, "a float-vector");
- x = 0.0;
beg = s7_integer(start);
lim = s7_integer(end);
d1 = s7_float_vector_elements(dline1);
@@ -4949,7 +4948,7 @@ static Xen g_singer_filter(Xen start, Xen end, Xen tmp, Xen dline1, Xen dline2,
for (k = beg, j = beg + 1; j < lim; k++, j++)
{
- s7_double temp1;
+ s7_double temp1, x;
x = d2[j + 1];
d2[j] = x + (cf[j] * (d1[k] - x));
temp1 = temp;
@@ -4966,7 +4965,7 @@ static Xen g_singer_nose_filter(Xen end, Xen tmp, Xen dline1, Xen dline2, Xen co
#define H_singer_nose_filter "this is an optimization for the singer instrument"
int j, k, lim;
s7_double *d1, *d2, *cf;
- s7_double reftemp, temp;
+ s7_double temp;
if (!s7_is_integer(end)) s7_wrong_type_arg_error(s7, S_singer_nose_filter, 1, end, "an integer");
if (!s7_is_real(tmp)) s7_wrong_type_arg_error(s7, S_singer_nose_filter, 2, tmp, "a real");
@@ -4974,7 +4973,6 @@ static Xen g_singer_nose_filter(Xen end, Xen tmp, Xen dline1, Xen dline2, Xen co
if (!s7_is_float_vector(dline2)) s7_wrong_type_arg_error(s7, S_singer_nose_filter, 4, dline2, "a float-vector");
if (!s7_is_float_vector(coeffs)) s7_wrong_type_arg_error(s7, S_singer_nose_filter, 5, coeffs, "a float-vector");
- reftemp = 0.0;
lim = s7_integer(end);
d1 = s7_float_vector_elements(dline1);
d2 = s7_float_vector_elements(dline2);
@@ -4983,7 +4981,7 @@ static Xen g_singer_nose_filter(Xen end, Xen tmp, Xen dline1, Xen dline2, Xen co
for (k = 1, j = 2; j < lim; k++, j++)
{
- s7_double t1;
+ s7_double t1, reftemp;
reftemp = cf[j] * (d1[k] - d2[j + 1]);
d2[j] = d2[j + 1] + reftemp;
t1 = temp;
@@ -9904,7 +9902,7 @@ static s7_double oscil_rf_ssx(s7_scheme *sc, s7_pointer **p)
s1 = (**p); (*p)++;
rf1 = (s7_rf_t)(**p); (*p)++;
v1 = rf1(sc, p);
- return(mus_oscil(g, s7_slot_real_value(sc, s1, "oscil"), v1));
+ return(mus_oscil(g, s7_slot_real_value(sc, s1, S_oscil), v1));
}
static s7_double oscil_rf_sss(s7_scheme *sc, s7_pointer **p)
@@ -9913,7 +9911,7 @@ static s7_double oscil_rf_sss(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
s2 = (**p); (*p)++;
- return(mus_oscil(g, s7_slot_real_value(sc, s1, "oscil"), s7_slot_real_value(sc, s2, "oscil")));
+ return(mus_oscil(g, s7_slot_real_value(sc, s1, S_oscil), s7_slot_real_value(sc, s2, S_oscil)));
}
static s7_double oscil_rf_srs(s7_scheme *sc, s7_pointer **p)
@@ -9922,7 +9920,7 @@ static s7_double oscil_rf_srs(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
s2 = (**p); (*p)++;
- return(mus_oscil(g, s7_number_to_real(sc, s1), s7_slot_real_value(sc, s2, "oscil")));
+ return(mus_oscil(g, s7_number_to_real(sc, s1), s7_slot_real_value(sc, s2, S_oscil)));
}
static s7_double oscil_rf_srx(s7_scheme *sc, s7_pointer **p)
@@ -9972,7 +9970,7 @@ static s7_double comb_rf_ssx(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
rf1 = (s7_rf_t)(**p); (*p)++;
- return(mus_comb(g, s7_slot_real_value(sc, s1, "comb"), rf1(sc, p)));
+ return(mus_comb(g, s7_slot_real_value(sc, s1, S_comb), rf1(sc, p)));
}
static s7_double comb_rf_sss(s7_scheme *sc, s7_pointer **p)
@@ -9981,7 +9979,7 @@ static s7_double comb_rf_sss(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
s2 = (**p); (*p)++;
- return(mus_comb(g, s7_slot_real_value(sc, s1, "comb"), s7_slot_real_value(sc, s2, "comb")));
+ return(mus_comb(g, s7_slot_real_value(sc, s1, S_comb), s7_slot_real_value(sc, s2, S_comb)));
}
static s7_rf_t comb_rf_3(s7_scheme *sc, s7_pointer expr)
@@ -10075,7 +10073,7 @@ static s7_double ssb_am_rf_sss(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
s2 = (**p); (*p)++;
- return(mus_ssb_am(g, s7_slot_real_value(sc, s1, "ssb-am"), s7_slot_real_value(sc, s2, "ssb-am")));
+ return(mus_ssb_am(g, s7_slot_real_value(sc, s1, S_ssb_am), s7_slot_real_value(sc, s2, S_ssb_am)));
}
static s7_rf_t ssb_am_rf_3(s7_scheme *sc, s7_pointer expr)
@@ -10098,7 +10096,7 @@ static s7_double formant_rf_ssx(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
rf1 = (s7_rf_t)(**p); (*p)++;
- return(mus_formant_with_frequency(g, s7_slot_real_value(sc, s1, "formant"), rf1(sc, p)));
+ return(mus_formant_with_frequency(g, s7_slot_real_value(sc, s1, S_formant), rf1(sc, p)));
}
static s7_double formant_rf_sss(s7_scheme *sc, s7_pointer **p)
@@ -10107,7 +10105,7 @@ static s7_double formant_rf_sss(s7_scheme *sc, s7_pointer **p)
mus_any *g; g = (mus_any *)(*(*p)); (*p)++;
s1 = (**p); (*p)++;
s2 = (**p); (*p)++;
- return(mus_formant_with_frequency(g, s7_slot_real_value(sc, s1, "formant"), s7_slot_real_value(sc, s2, "formant")));
+ return(mus_formant_with_frequency(g, s7_slot_real_value(sc, s1, S_formant), s7_slot_real_value(sc, s2, S_formant)));
}
static s7_rf_t formant_rf_3(s7_scheme *sc, s7_pointer expr)
@@ -10131,7 +10129,7 @@ static s7_double formant_bank_rf_s(s7_scheme *sc, s7_pointer **p)
s7_pointer slot;
bank = (mus_any *)(**p); (*p)++;
slot = (**p); (*p)++;
- return(mus_formant_bank(bank, s7_slot_real_value(sc, slot, "formant-bank")));
+ return(mus_formant_bank(bank, s7_slot_real_value(sc, slot, S_formant_bank)));
}
static s7_double formant_bank_rf_r(s7_scheme *sc, s7_pointer **p)
@@ -10284,7 +10282,7 @@ static s7_double outa_s_rf(s7_scheme *sc, s7_pointer **p)
s7_int ind;
ind = s7_slot_integer_value(**p); (*p)++;
- val = s7_slot_real_value(sc, **p, "outa"); (*p)++;
+ val = s7_slot_real_value(sc, **p, S_outa); (*p)++;
out_any_2(ind, val, 0, S_outa);
return(val);
}
@@ -10296,7 +10294,7 @@ static s7_double outa_s_rf_checked(s7_scheme *sc, s7_pointer **p)
ind = s7_slot_value(**p); (*p)++;
if (!s7_is_integer(ind)) s7_wrong_type_arg_error(s7, S_outa, 1, ind, "an integer");
- val = s7_slot_real_value(sc, **p, "outa"); (*p)++;
+ val = s7_slot_real_value(sc, **p, S_outa); (*p)++;
out_any_2(s7_integer(ind), val, 0, S_outa);
return(val);
}
@@ -10322,7 +10320,7 @@ static s7_double outa_s_rf_to_mus_xen(s7_scheme *sc, s7_pointer **p)
s7_int pos;
pos = s7_slot_integer_value(**p); (*p)++;
- val = s7_slot_real_value(sc, **p, "outa"); (*p)++;
+ val = s7_slot_real_value(sc, **p, S_outa); (*p)++;
if (!mus_simple_out_any_to_file(pos, val, 0, clm_output_gen))
mus_safe_out_any_to_file(pos, val, 0, clm_output_gen);
return(val);
@@ -10347,7 +10345,7 @@ static s7_double outb_s_rf(s7_scheme *sc, s7_pointer **p)
s7_double val;
ind = s7_slot_integer_value(**p); (*p)++;
- val = s7_slot_real_value(sc, **p, "outb"); (*p)++;
+ val = s7_slot_real_value(sc, **p, S_outb); (*p)++;
out_any_2(ind, val, 1, S_outb);
return(val);
}
@@ -10587,7 +10585,7 @@ static s7_double locsig_fm_violin_rf(s7_scheme *sc, s7_pointer **p)
/* fm_violin_rf */
e = (mus_any *)(**p); (*p) += 2;
o = (mus_any *)(**p); (*p) += 2;
- vib = s7_slot_real_value(sc, **p, "oscil"); (*p) += 3;
+ vib = s7_slot_real_value(sc, **p, S_oscil); (*p) += 3;
a = (mus_any *)(**p); (*p) += 2;
fp = (mus_any *)(**p); (*p)++;
val = mus_env(e) * mus_oscil_fm(o, vib + (mus_env(a) * mus_polywave(fp, vib)));
@@ -11467,7 +11465,7 @@ static s7_double fm_violin_rf(s7_scheme *sc, s7_pointer **p)
(*p)++;
e = (mus_any *)(**p); (*p) += 2;
o = (mus_any *)(**p); (*p) += 2;
- vib = s7_slot_real_value(sc, **p, "oscil"); (*p) += 3;
+ vib = s7_slot_real_value(sc, **p, S_oscil); (*p) += 3;
a = (mus_any *)(**p); (*p) += 2;
fp = (mus_any *)(**p); (*p)++;
return(mus_env(e) * mus_oscil_fm(o, vib + (mus_env(a) * mus_polywave(fp, vib))));
@@ -11491,7 +11489,7 @@ static s7_double mul_env_polywave_s_rf(s7_scheme *sc, s7_pointer **p)
(*p)++;
e = (mus_any *)(**p); (*p) += 2;
o = (mus_any *)(**p); (*p)++;
- s1 = s7_slot_real_value(sc, **p, "polywave"); (*p)++;
+ s1 = s7_slot_real_value(sc, **p, S_polywave); (*p)++;
return(mus_env(e) * mus_polywave(o, s1));
}
@@ -11500,7 +11498,7 @@ static s7_double mul_s_comb_bank_x_rf(s7_scheme *sc, s7_pointer **p)
s7_rf_t r1;
s7_double s1;
mus_any *o;
- s1 = s7_slot_real_value(sc, **p, "comb-bank"); (*p) += 2;
+ s1 = s7_slot_real_value(sc, **p, S_comb_bank); (*p) += 2;
o = (mus_any *)(**p); (*p)++;
r1 = (s7_rf_t)(**p); (*p)++;
return(s1 * mus_comb_bank(o, r1(sc, p)));
@@ -11933,13 +11931,13 @@ static void init_choosers(s7_scheme *sc)
s7_pointer f;
#endif
- env_symbol = s7_make_symbol(sc, "env");
- comb_bank_symbol = s7_make_symbol(sc, "comb-bank");
+ env_symbol = s7_make_symbol(sc, S_env);
+ comb_bank_symbol = s7_make_symbol(sc, S_comb_bank);
vector_ref_symbol = s7_make_symbol(sc, "vector-ref");
- polywave_symbol = s7_make_symbol(sc, "polywave");
- triangle_wave_symbol = s7_make_symbol(sc, "triangle-wave");
- rand_interp_symbol = s7_make_symbol(sc, "rand-interp");
- oscil_symbol = s7_make_symbol(sc, "oscil");
+ polywave_symbol = s7_make_symbol(sc, S_polywave);
+ triangle_wave_symbol = s7_make_symbol(sc, S_triangle_wave);
+ rand_interp_symbol = s7_make_symbol(sc, S_rand_interp);
+ oscil_symbol = s7_make_symbol(sc, S_oscil);
multiply_symbol = s7_make_symbol(sc, "*");
add_symbol = s7_make_symbol(sc, "+");
quote_symbol = s7_make_symbol(sc, "quote");
@@ -12494,10 +12492,10 @@ static void mus_xen_init(void)
#if HAVE_SCHEME
s7_pointer s, i, p, t, r, c, f, v, b, d, j;
- s7_pointer pcl_ct, pl_rcr, pl_bt, pl_ir, pl_cc, pl_ccic, pl_ccrr, pl_fc, pl_fcif, pl_cs, pl_ff, pl_tt, pl_fffifi, pl_ffftii, pl_fffi,
- pl_fti, pl_fif, pl_fiir, pl_fttb, pl_ic, pl_rciir, pl_rcir, pl_ririt, pl_rcrr, pl_rirt, pl_riirfff, pl_rirfff, pl_rrpr, pcl_zt,
- pl_sc, pl_sssrs, pl_tc, pl_ct, pl_ici, pl_i, pl_fcf, pl_dcr, pl_dr, pl_dffi, pl_dfri, pl_dirfir, pl_dc, pl_dci, pl_dcir, pl_dv,
- pl_dvir, pl_drf, pl_drc, pl_diit, pl_dit, pl_dct, pl_d, pl_dcf, pl_dcrt, pl_djr, pl_it, pl_iti;
+ s7_pointer pl_rcr, pl_bt, pl_ir, pl_cc, pl_ccic, pl_ccrr, pl_fc, pl_fcif, pl_cs, pl_ff, pl_tt, pl_fffifi, pl_ffftii, pl_fffi,
+ pl_fti, pl_fif, pl_fiir, pl_fttb, pl_ic, pl_rciir, pl_rcir, pl_ririt, pl_rcrr, pl_rirt, pl_riirfff, pl_rirfff, pl_rrpr,
+ pl_sc, pl_sssrs, pl_tc, pl_ici, pl_i, pl_fcf, pl_dcr, pl_dr, pl_dffi, pl_dfri, pl_dirfir, pl_dc, pl_dci, pl_dcir, pl_dv,
+ pl_dvir, pl_drf, pl_drc, pl_diit, pl_dit, pl_dct, pl_d, pl_djr, pl_it, pl_iti;
#endif
mus_initialize();
@@ -12515,23 +12513,19 @@ static void mus_xen_init(void)
p = s7_make_symbol(s7, "pair?");
t = s7_t(s7);
r = s7_make_symbol(s7, "real?");
- c = s7_make_symbol(s7, "c-object?");
+ c = s7_t(s7); /* s7_make_symbol(s7, "c-object?"): this should be mus-generator which should match against oscil? etc -- maybe someday... */
f = s7_make_symbol(s7, "float-vector?");
j = s7_make_symbol(s7, "int-vector?");
v = s7_make_symbol(s7, "vector?");
b = s7_make_symbol(s7, "boolean?");
d = s7_make_symbol(s7, "float?");
- pcl_ct = s7_make_circular_signature(s7, 1, 2, c, t);
- pcl_zt = s7_make_circular_signature(s7, 1, 2, s7_make_signature(s7, 2, b, c), t);
pl_bt = s7_make_signature(s7, 2, b, t);
pl_rcr = s7_make_signature(s7, 3, r, c, r);
pl_d = s7_make_signature(s7, 1, d);
pl_dcr = s7_make_circular_signature(s7, 2, 3, d, c, r);
pl_djr = s7_make_circular_signature(s7, 2, 3, d, j, r);
- pl_dcf = s7_make_signature(s7, 3, d, c, s7_make_signature(s7, 2, r, f));
- pl_dcrt = s7_make_signature(s7, 4, d, c, r, t);
pl_dct = s7_make_signature(s7, 3, d, c, t);
pl_dci = s7_make_circular_signature(s7, 2, 3, d, c, i);
pl_dcir = s7_make_signature(s7, 4, d, c, i, r);
@@ -12549,11 +12543,10 @@ static void mus_xen_init(void)
pl_ir = s7_make_signature(s7, 2, i, r);
pl_i = s7_make_circular_signature(s7, 0, 1, i);
- pl_ct = s7_make_signature(s7, 2, c, t);
pl_cc = s7_make_circular_signature(s7, 1, 2, c, c);
pl_ici = s7_make_signature(s7, 3, i, c, i);
pl_iti = s7_make_signature(s7, 3, i, t, i);
- pl_ccic = s7_make_signature(s7, 3, c, c, i, c);
+ pl_ccic = s7_make_signature(s7, 4, c, c, i, c);
pl_ccrr = s7_make_signature(s7, 4, c, c, r, r);
pl_fc = s7_make_signature(s7, 2, s7_make_signature(s7, 2, f, b), c);
pl_cs = s7_make_signature(s7, 2, c, s);
@@ -12565,7 +12558,7 @@ static void mus_xen_init(void)
pl_fffi = s7_make_circular_signature(s7, 3, 4, f, f, f, i);
pl_fti = s7_make_signature(s7, 3, f, t, i);
pl_fif = s7_make_signature(s7, 3, f, i, f);
- pl_fiir = s7_make_signature(s7, 4, f, i, i, r);
+ pl_fiir = s7_make_circular_signature(s7, 3, 4, f, i, i, r);
pl_fttb = s7_make_signature(s7, 4, f, t, t, b);
pl_ic = s7_make_signature(s7, 2, i, c);
pl_it = s7_make_signature(s7, 2, i, t);
@@ -12795,24 +12788,42 @@ static void mus_xen_init(void)
Xen_define_procedure(S_mus_apply, g_mus_apply_w, 0, 0, 1, H_mus_apply);
- Xen_define_typed_procedure(S_make_delay, g_make_delay_w, 0, 0, 1, H_make_delay, pcl_ct);
- Xen_define_typed_procedure(S_make_comb, g_make_comb_w, 0, 0, 1, H_make_comb, pcl_ct);
- Xen_define_typed_procedure(S_make_filtered_comb, g_make_filtered_comb_w, 0, 0, 1, H_make_filtered_comb, pcl_ct);
- Xen_define_typed_procedure(S_make_notch, g_make_notch_w, 0, 0, 1, H_make_notch, pcl_ct);
- Xen_define_typed_procedure(S_make_all_pass, g_make_all_pass_w, 0, 0, 1, H_make_all_pass, pcl_ct);
- Xen_define_typed_procedure(S_make_moving_average, g_make_moving_average_w, 0, 0, 1, H_make_moving_average, pcl_ct);
- Xen_define_typed_procedure(S_make_moving_max, g_make_moving_max_w, 0, 0, 1, H_make_moving_max, pcl_ct);
- Xen_define_typed_procedure(S_make_moving_norm, g_make_moving_norm_w, 0, 0, 1, H_make_moving_norm, pcl_ct);
- Xen_define_typed_procedure(S_delay, g_delay_w, 1, 2, 0, H_delay, pl_dcr);
- Xen_define_typed_procedure(S_delay_tick, g_delay_tick_w, 1, 1, 0, H_delay_tick, pl_dcr);
- Xen_define_typed_procedure(S_tap, g_tap_w, 1, 1, 0, H_tap, pl_dcr);
- Xen_define_typed_procedure(S_notch, g_notch_w, 1, 2, 0, H_notch, pl_dcr);
- Xen_define_typed_procedure(S_comb, g_comb_w, 1, 2, 0, H_comb, pl_dcr);
- Xen_define_typed_procedure(S_filtered_comb, g_filtered_comb_w, 1, 2, 0, H_filtered_comb, pl_dcr);
- Xen_define_typed_procedure(S_all_pass, g_all_pass_w, 1, 2, 0, H_all_pass, pl_dcr);
- Xen_define_typed_procedure(S_moving_average, g_moving_average_w, 1, 1, 0, H_moving_average, pl_dcr);
- Xen_define_typed_procedure(S_moving_max, g_moving_max_w, 1, 1, 0, H_moving_max, pl_dcr);
- Xen_define_typed_procedure(S_moving_norm, g_moving_norm_w, 1, 1, 0, H_moving_norm, pl_dcr);
+ Xen_define_typed_procedure(S_make_delay, g_make_delay_w, 0, 0, 1, H_make_delay,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_delay), t));
+ Xen_define_typed_procedure(S_make_comb, g_make_comb_w, 0, 0, 1, H_make_comb,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_comb), t));
+ Xen_define_typed_procedure(S_make_filtered_comb, g_make_filtered_comb_w, 0, 0, 1, H_make_filtered_comb,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_filtered_comb), t));
+ Xen_define_typed_procedure(S_make_notch, g_make_notch_w, 0, 0, 1, H_make_notch,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_notch), t));
+ Xen_define_typed_procedure(S_make_all_pass, g_make_all_pass_w, 0, 0, 1, H_make_all_pass,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_all_pass), t));
+ Xen_define_typed_procedure(S_make_moving_average, g_make_moving_average_w, 0, 0, 1, H_make_moving_average,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_moving_average), t));
+ Xen_define_typed_procedure(S_make_moving_max, g_make_moving_max_w, 0, 0, 1, H_make_moving_max,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_moving_max), t));
+ Xen_define_typed_procedure(S_make_moving_norm, g_make_moving_norm_w, 0, 0, 1, H_make_moving_norm,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_moving_norm), t));
+ Xen_define_typed_procedure(S_delay, g_delay_w, 1, 2, 0, H_delay,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_delay), r));
+ Xen_define_typed_procedure(S_delay_tick, g_delay_tick_w, 1, 1, 0, H_delay_tick,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_delay), r));
+ Xen_define_typed_procedure(S_tap, g_tap_w, 1, 1, 0, H_tap,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_delay), r));
+ Xen_define_typed_procedure(S_notch, g_notch_w, 1, 2, 0, H_notch,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_notch), r));
+ Xen_define_typed_procedure(S_comb, g_comb_w, 1, 2, 0, H_comb,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_comb), r));
+ Xen_define_typed_procedure(S_filtered_comb, g_filtered_comb_w, 1, 2, 0, H_filtered_comb,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_filtered_comb), r));
+ Xen_define_typed_procedure(S_all_pass, g_all_pass_w, 1, 2, 0, H_all_pass,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_all_pass), r));
+ Xen_define_typed_procedure(S_moving_average, g_moving_average_w, 1, 1, 0, H_moving_average,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_moving_average), r));
+ Xen_define_typed_procedure(S_moving_max, g_moving_max_w, 1, 1, 0, H_moving_max,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_moving_max), r));
+ Xen_define_typed_procedure(S_moving_norm, g_moving_norm_w, 1, 1, 0, H_moving_norm,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_moving_norm), r));
Xen_define_typed_procedure(S_is_tap, g_is_tap_w, 1, 0, 0, H_is_tap, pl_bt);
Xen_define_typed_procedure(S_is_delay, g_is_delay_w, 1, 0, 0, H_is_delay, pl_bt);
Xen_define_typed_procedure(S_is_notch, g_is_notch_w, 1, 0, 0, H_is_notch, pl_bt);
@@ -12823,17 +12834,23 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_is_moving_max, g_is_moving_max_w, 1, 0, 0, H_is_moving_max, pl_bt);
Xen_define_typed_procedure(S_is_moving_norm, g_is_moving_norm_w, 1, 0, 0, H_is_moving_norm, pl_bt);
- Xen_define_typed_procedure(S_comb_bank, g_comb_bank_w, 1, 1, 0, H_comb_bank, pl_dcr);
+ Xen_define_typed_procedure(S_comb_bank, g_comb_bank_w, 1, 1, 0, H_comb_bank,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_comb_bank), r));
Xen_define_typed_procedure(S_is_comb_bank, g_is_comb_bank_w, 1, 0, 0, H_is_comb_bank, pl_bt);
- Xen_define_typed_procedure(S_make_comb_bank, g_make_comb_bank_w, 1, 0, 0, H_make_comb_bank, pcl_ct);
+ Xen_define_typed_procedure(S_make_comb_bank, g_make_comb_bank_w, 1, 0, 0, H_make_comb_bank,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_comb_bank), t));
- Xen_define_typed_procedure(S_filtered_comb_bank, g_filtered_comb_bank_w, 1, 1, 0, H_filtered_comb_bank, pl_dcr);
+ Xen_define_typed_procedure(S_filtered_comb_bank, g_filtered_comb_bank_w, 1, 1, 0, H_filtered_comb_bank,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_filtered_comb_bank), r));
Xen_define_typed_procedure(S_is_filtered_comb_bank, g_is_filtered_comb_bank_w, 1, 0, 0, H_is_filtered_comb_bank, pl_bt);
- Xen_define_typed_procedure(S_make_filtered_comb_bank, g_make_filtered_comb_bank_w, 1, 0, 0, H_make_filtered_comb_bank, pcl_ct);
+ Xen_define_typed_procedure(S_make_filtered_comb_bank, g_make_filtered_comb_bank_w, 1, 0, 0, H_make_filtered_comb_bank,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_filtered_comb_bank), t));
- Xen_define_typed_procedure(S_all_pass_bank, g_all_pass_bank_w, 1, 1, 0, H_all_pass_bank, pl_dcr);
+ Xen_define_typed_procedure(S_all_pass_bank, g_all_pass_bank_w, 1, 1, 0, H_all_pass_bank,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_all_pass_bank), r));
Xen_define_typed_procedure(S_is_all_pass_bank, g_is_all_pass_bank_w, 1, 0, 0, H_is_all_pass_bank, pl_bt);
- Xen_define_typed_procedure(S_make_all_pass_bank, g_make_all_pass_bank_w, 1, 0, 0, H_make_all_pass_bank, pcl_ct);
+ Xen_define_typed_procedure(S_make_all_pass_bank, g_make_all_pass_bank_w, 1, 0, 0, H_make_all_pass_bank,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_all_pass_bank), t));
Xen_define_typed_procedure(S_pink_noise, g_pink_noise_w, 1, 0, 0, H_pink_noise, pl_dv);
@@ -12844,13 +12861,17 @@ static void mus_xen_init(void)
Xen_define_typed_dilambda(S_mus_feedforward, g_mus_feedforward_w, H_mus_feedforward,
S_set S_mus_feedforward, g_mus_set_feedforward_w, 1, 0, 2, 0, pl_dc, pl_dcr);
- Xen_define_typed_procedure(S_make_rand, g_make_rand_w, 0, 0, 1, H_make_rand, pcl_ct);
- Xen_define_typed_procedure(S_make_rand_interp, g_make_rand_interp_w, 0, 0, 1, H_make_rand_interp, pcl_ct);
+ Xen_define_typed_procedure(S_make_rand, g_make_rand_w, 0, 0, 1, H_make_rand,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_rand), t));
+ Xen_define_typed_procedure(S_make_rand_interp, g_make_rand_interp_w, 0, 0, 1, H_make_rand_interp,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_rand_interp), t));
#if HAVE_RUBY
rb_define_alias(rb_mKernel, "kernel_rand", "rand");
#endif
- Xen_define_typed_procedure(S_rand, g_rand_w, 1, 1, 0, H_rand, pl_dcr);
- Xen_define_typed_procedure(S_rand_interp, g_rand_interp_w, 1, 1, 0, H_rand_interp, pl_dcr);
+ Xen_define_typed_procedure(S_rand, g_rand_w, 1, 1, 0, H_rand,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_rand), r));
+ Xen_define_typed_procedure(S_rand_interp, g_rand_interp_w, 1, 1, 0, H_rand_interp,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_rand_interp), r));
Xen_define_typed_procedure(S_is_rand, g_is_rand_w, 1, 0, 0, H_is_rand, pl_bt);
Xen_define_typed_procedure(S_is_rand_interp, g_is_rand_interp_w, 1, 0, 0, H_is_rand_interp, pl_bt);
Xen_define_typed_procedure(S_mus_random, g_mus_random_w, 1, 0, 0, H_mus_random, pl_dr);
@@ -12858,129 +12879,184 @@ static void mus_xen_init(void)
Xen_define_typed_dilambda(S_mus_rand_seed, g_mus_rand_seed_w, H_mus_rand_seed,
S_set S_mus_rand_seed, g_mus_set_rand_seed_w, 0, 0, 1, 0, pl_i, pl_i);
- Xen_define_typed_procedure(S_ncos, g_ncos_w, 1, 1, 0, H_ncos, pl_dcr);
+ Xen_define_typed_procedure(S_ncos, g_ncos_w, 1, 1, 0, H_ncos,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_ncos), r));
Xen_define_typed_procedure(S_is_ncos, g_is_ncos_w, 1, 0, 0, H_is_ncos, pl_bt);
- Xen_define_typed_procedure(S_nsin, g_nsin_w, 1, 1, 0, H_nsin, pl_dcr);
+ Xen_define_typed_procedure(S_nsin, g_nsin_w, 1, 1, 0, H_nsin,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_nsin), r));
Xen_define_typed_procedure(S_is_nsin, g_is_nsin_w, 1, 0, 0, H_is_nsin, pl_bt);
Xen_define_typed_procedure(S_is_table_lookup, g_is_table_lookup_w, 1, 0, 0, H_is_table_lookup, pl_bt);
- Xen_define_typed_procedure(S_make_table_lookup, g_make_table_lookup_w, 0, 0, 1, H_make_table_lookup, pcl_ct);
- Xen_define_typed_procedure(S_table_lookup, g_table_lookup_w, 1, 1, 0, H_table_lookup, pl_dcr);
+ Xen_define_typed_procedure(S_make_table_lookup, g_make_table_lookup_w, 0, 0, 1, H_make_table_lookup,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_table_lookup), t));
+ Xen_define_typed_procedure(S_table_lookup, g_table_lookup_w, 1, 1, 0, H_table_lookup,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_table_lookup), r));
Xen_define_typed_procedure(S_partials_to_wave, g_partials_to_wave_w, 1, 2, 0, H_partials_to_wave, pl_fttb);
Xen_define_typed_procedure(S_phase_partials_to_wave, g_phase_partials_to_wave_w, 1, 2, 0, H_phase_partials_to_wave, pl_fttb);
- Xen_define_typed_procedure(S_make_sawtooth_wave, g_make_sawtooth_wave_w, 0, 6, 0, H_make_sawtooth_wave, pcl_ct);
- Xen_define_typed_procedure(S_sawtooth_wave, g_sawtooth_wave_w, 1, 1, 0, H_sawtooth_wave, pl_dcr);
+ Xen_define_typed_procedure(S_make_sawtooth_wave, g_make_sawtooth_wave_w, 0, 6, 0, H_make_sawtooth_wave,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_sawtooth_wave), t));
+ Xen_define_typed_procedure(S_sawtooth_wave, g_sawtooth_wave_w, 1, 1, 0, H_sawtooth_wave,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_sawtooth_wave), r));
Xen_define_typed_procedure(S_is_sawtooth_wave, g_is_sawtooth_wave_w, 1, 0, 0, H_is_sawtooth_wave, pl_bt);
- Xen_define_typed_procedure(S_make_triangle_wave, g_make_triangle_wave_w, 0, 6, 0, H_make_triangle_wave, pcl_ct);
- Xen_define_typed_procedure(S_triangle_wave, g_triangle_wave_w, 1, 1, 0, H_triangle_wave, pl_dcr);
+ Xen_define_typed_procedure(S_make_triangle_wave, g_make_triangle_wave_w, 0, 6, 0, H_make_triangle_wave,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_triangle_wave), t));
+ Xen_define_typed_procedure(S_triangle_wave, g_triangle_wave_w, 1, 1, 0, H_triangle_wave,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_triangle_wave), r));
Xen_define_typed_procedure(S_is_triangle_wave, g_is_triangle_wave_w, 1, 0, 0, H_is_triangle_wave, pl_bt);
- Xen_define_typed_procedure(S_make_square_wave, g_make_square_wave_w, 0, 6, 0, H_make_square_wave, pcl_ct);
- Xen_define_typed_procedure(S_square_wave, g_square_wave_w, 1, 1, 0, H_square_wave, pl_dcr);
+ Xen_define_typed_procedure(S_make_square_wave, g_make_square_wave_w, 0, 6, 0, H_make_square_wave,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_square_wave), t));
+ Xen_define_typed_procedure(S_square_wave, g_square_wave_w, 1, 1, 0, H_square_wave,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_square_wave), r));
Xen_define_typed_procedure(S_is_square_wave, g_is_square_wave_w, 1, 0, 0, H_is_square_wave, pl_bt);
- Xen_define_typed_procedure(S_make_pulse_train, g_make_pulse_train_w, 0, 6, 0, H_make_pulse_train, pcl_ct);
- Xen_define_typed_procedure(S_pulse_train, g_pulse_train_w, 1, 1, 0, H_pulse_train, pl_dcr);
+ Xen_define_typed_procedure(S_make_pulse_train, g_make_pulse_train_w, 0, 6, 0, H_make_pulse_train,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_pulse_train), t));
+ Xen_define_typed_procedure(S_pulse_train, g_pulse_train_w, 1, 1, 0, H_pulse_train,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_pulse_train), r));
Xen_define_typed_procedure(S_is_pulse_train, g_is_pulse_train_w, 1, 0, 0, H_is_pulse_train, pl_bt);
- Xen_define_typed_procedure(S_make_pulsed_env, g_make_pulsed_env_w, 3, 0, 0, H_make_pulsed_env, pcl_ct);
- Xen_define_typed_procedure(S_pulsed_env, g_pulsed_env_w, 1, 1, 0, H_pulsed_env, pl_dcr);
+ Xen_define_typed_procedure(S_make_pulsed_env, g_make_pulsed_env_w, 3, 0, 0, H_make_pulsed_env,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_pulsed_env), t));
+ Xen_define_typed_procedure(S_pulsed_env, g_pulsed_env_w, 1, 1, 0, H_pulsed_env,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_pulsed_env), r));
Xen_define_typed_procedure(S_is_pulsed_env, g_is_pulsed_env_w, 1, 0, 0, H_is_pulsed_env, pl_bt);
- Xen_define_typed_procedure(S_asymmetric_fm, g_asymmetric_fm_w, 1, 2, 0, H_asymmetric_fm, pl_dcr);
+ Xen_define_typed_procedure(S_asymmetric_fm, g_asymmetric_fm_w, 1, 2, 0, H_asymmetric_fm,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_asymmetric_fm), r));
Xen_define_typed_procedure(S_is_asymmetric_fm, g_is_asymmetric_fm_w, 1, 0, 0, H_is_asymmetric_fm, pl_bt);
- Xen_define_typed_procedure(S_make_one_zero, g_make_one_zero_w, 0, 4, 0, H_make_one_zero, pcl_ct);
- Xen_define_typed_procedure(S_one_zero, g_one_zero_w, 1, 1, 0, H_one_zero, pl_dcr);
+ Xen_define_typed_procedure(S_make_one_zero, g_make_one_zero_w, 0, 4, 0, H_make_one_zero,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_one_zero), t));
+ Xen_define_typed_procedure(S_one_zero, g_one_zero_w, 1, 1, 0, H_one_zero,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_one_zero), r));
Xen_define_typed_procedure(S_is_one_zero, g_is_one_zero_w, 1, 0, 0, H_is_one_zero, pl_bt);
- Xen_define_typed_procedure(S_make_one_pole, g_make_one_pole_w, 0, 4, 0, H_make_one_pole, pcl_ct);
- Xen_define_typed_procedure(S_one_pole, g_one_pole_w, 1, 1, 0, H_one_pole, pl_dcr);
+ Xen_define_typed_procedure(S_make_one_pole, g_make_one_pole_w, 0, 4, 0, H_make_one_pole,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_one_pole), t));
+ Xen_define_typed_procedure(S_one_pole, g_one_pole_w, 1, 1, 0, H_one_pole,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_one_pole), r));
Xen_define_typed_procedure(S_is_one_pole, g_is_one_pole_w, 1, 0, 0, H_is_one_pole, pl_bt);
- Xen_define_typed_procedure(S_make_two_zero, g_make_two_zero_w, 0, 6, 0, H_make_two_zero, pcl_ct);
- Xen_define_typed_procedure(S_two_zero, g_two_zero_w, 1, 1, 0, H_two_zero, pl_dcr);
+ Xen_define_typed_procedure(S_make_two_zero, g_make_two_zero_w, 0, 6, 0, H_make_two_zero,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_two_zero), t));
+ Xen_define_typed_procedure(S_two_zero, g_two_zero_w, 1, 1, 0, H_two_zero,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_two_zero), r));
Xen_define_typed_procedure(S_is_two_zero, g_is_two_zero_w, 1, 0, 0, H_is_two_zero, pl_bt);
- Xen_define_typed_procedure(S_make_two_pole, g_make_two_pole_w, 0, 6, 0, H_make_two_pole, pcl_ct);
- Xen_define_typed_procedure(S_two_pole, g_two_pole_w, 1, 1, 0, H_two_pole, pl_dcr);
+ Xen_define_typed_procedure(S_make_two_pole, g_make_two_pole_w, 0, 6, 0, H_make_two_pole,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_two_pole), t));
+ Xen_define_typed_procedure(S_two_pole, g_two_pole_w, 1, 1, 0, H_two_pole,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_two_pole), r));
Xen_define_typed_procedure(S_is_two_pole, g_is_two_pole_w, 1, 0, 0, H_is_two_pole, pl_bt);
- Xen_define_typed_procedure(S_make_wave_train, g_make_wave_train_w, 0, 0, 1, H_make_wave_train, pcl_ct);
- Xen_define_typed_procedure(S_wave_train, g_wave_train_w, 1, 1, 0, H_wave_train, pl_dcr);
+ Xen_define_typed_procedure(S_make_wave_train, g_make_wave_train_w, 0, 0, 1, H_make_wave_train,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_wave_train), t));
+ Xen_define_typed_procedure(S_wave_train, g_wave_train_w, 1, 1, 0, H_wave_train,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_wave_train), r));
Xen_define_typed_procedure(S_is_wave_train, g_is_wave_train_w, 1, 0, 0, H_is_wave_train, pl_bt);
Xen_define_typed_procedure(S_is_formant, g_is_formant_w, 1, 0, 0, H_is_formant, pl_bt);
- Xen_define_typed_procedure(S_make_formant, g_make_formant_w, 0, 4, 0, H_make_formant, pcl_ct);
- Xen_define_typed_procedure(S_formant, g_formant_w, 1, 2, 0, H_formant, pl_dcr);
+ Xen_define_typed_procedure(S_make_formant, g_make_formant_w, 0, 4, 0, H_make_formant,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_formant), t));
+ Xen_define_typed_procedure(S_formant, g_formant_w, 1, 2, 0, H_formant,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_formant), r));
- Xen_define_typed_procedure(S_formant_bank, g_formant_bank_w, 1, 1, 0, H_formant_bank, pl_dcf);
+ Xen_define_typed_procedure(S_formant_bank, g_formant_bank_w, 1, 1, 0, H_formant_bank,
+ s7_make_signature(s7, 3, d, s7_make_symbol(s7, S_is_formant_bank), s7_make_signature(s7, 2, r, f)));
Xen_define_typed_procedure(S_is_formant_bank, g_is_formant_bank_w, 1, 0, 0, H_is_formant_bank, pl_bt);
- Xen_define_typed_procedure(S_make_formant_bank, g_make_formant_bank_w, 1, 1, 0, H_make_formant_bank, pcl_zt);
+ Xen_define_typed_procedure(S_make_formant_bank, g_make_formant_bank_w, 1, 1, 0, H_make_formant_bank,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_formant_bank), t));
Xen_define_typed_procedure(S_is_firmant, g_is_firmant_w, 1, 0, 0, H_is_firmant, pl_bt);
- Xen_define_typed_procedure(S_make_firmant, g_make_firmant_w, 0, 4, 0, H_make_firmant, pcl_ct);
- Xen_define_typed_procedure(S_firmant, g_firmant_w, 1, 2, 0, H_firmant, pl_dcr);
+ Xen_define_typed_procedure(S_make_firmant, g_make_firmant_w, 0, 4, 0, H_make_firmant,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_firmant), t));
+ Xen_define_typed_procedure(S_firmant, g_firmant_w, 1, 2, 0, H_firmant,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_firmant), r));
Xen_define_typed_procedure(S_is_one_pole_all_pass, g_is_one_pole_all_pass_w, 1, 0, 0, H_is_one_pole_all_pass, pl_bt);
- Xen_define_typed_procedure(S_make_one_pole_all_pass, g_make_one_pole_all_pass_w, 2, 0, 0, H_make_one_pole_all_pass, pcl_ct);
- Xen_define_typed_procedure(S_one_pole_all_pass, g_one_pole_all_pass_w, 1, 1, 0, H_one_pole_all_pass, pl_dcr);
+ Xen_define_typed_procedure(S_make_one_pole_all_pass, g_make_one_pole_all_pass_w, 2, 0, 0, H_make_one_pole_all_pass,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_one_pole_all_pass), t));
+ Xen_define_typed_procedure(S_one_pole_all_pass, g_one_pole_all_pass_w, 1, 1, 0, H_one_pole_all_pass,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_one_pole_all_pass), r));
Xen_define_typed_procedure(S_mus_set_formant_frequency, g_set_formant_frequency_w, 2, 0, 0, H_mus_set_formant_frequency, pl_rcr);
Xen_define_typed_procedure(S_mus_set_formant_radius_and_frequency, g_set_formant_radius_and_frequency_w, 3, 0, 0, H_mus_set_formant_radius_and_frequency, pl_rcrr);
- Xen_define_typed_procedure(S_make_polyshape, g_make_polyshape_w, 0, 0, 1, H_make_polyshape, pcl_ct);
- Xen_define_typed_procedure(S_polyshape, g_polyshape_w, 1, 2, 0, H_polyshape, pl_dcr);
+ Xen_define_typed_procedure(S_make_polyshape, g_make_polyshape_w, 0, 0, 1, H_make_polyshape,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_polyshape), t));
+ Xen_define_typed_procedure(S_polyshape, g_polyshape_w, 1, 2, 0, H_polyshape,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_polyshape), r));
Xen_define_typed_procedure(S_is_polyshape, g_is_polyshape_w, 1, 0, 0, H_is_polyshape, pl_bt);
Xen_define_typed_procedure(S_partials_to_polynomial, g_partials_to_polynomial_w, 1, 1, 0, H_partials_to_polynomial, pl_fti);
Xen_define_typed_procedure(S_normalize_partials, g_normalize_partials_w, 1, 0, 0, H_normalize_partials, pl_tt);
Xen_define_typed_procedure(S_mus_chebyshev_t_sum, g_chebyshev_t_sum_w, 2, 0, 0, H_chebyshev_t_sum, pl_drf);
Xen_define_typed_procedure(S_mus_chebyshev_u_sum, g_chebyshev_u_sum_w, 2, 0, 0, H_chebyshev_u_sum, pl_drf);
Xen_define_typed_procedure(S_mus_chebyshev_tu_sum, g_chebyshev_tu_sum_w, 3, 0, 0, H_chebyshev_tu_sum, pl_drf);
- Xen_define_typed_procedure(S_make_polywave, g_make_polywave_w, 0, 0, 1, H_make_polywave, pcl_ct);
- Xen_define_typed_procedure(S_polywave, g_polywave_w, 1, 1, 0, H_polywave, pl_dcr);
+ Xen_define_typed_procedure(S_make_polywave, g_make_polywave_w, 0, 0, 1, H_make_polywave,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_polywave), t));
+ Xen_define_typed_procedure(S_polywave, g_polywave_w, 1, 1, 0, H_polywave,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_polywave), r));
Xen_define_typed_procedure(S_is_polywave, g_is_polywave_w, 1, 0, 0, H_is_polywave, pl_bt);
- Xen_define_typed_procedure(S_make_nrxysin, g_make_nrxysin_w, 0, 0, 1, H_make_nrxysin, pcl_ct);
- Xen_define_typed_procedure(S_nrxysin, g_nrxysin_w, 1, 1, 0, H_nrxysin, pl_dcr);
+ Xen_define_typed_procedure(S_make_nrxysin, g_make_nrxysin_w, 0, 0, 1, H_make_nrxysin,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_nrxysin), t));
+ Xen_define_typed_procedure(S_nrxysin, g_nrxysin_w, 1, 1, 0, H_nrxysin,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_nrxysin), r));
Xen_define_typed_procedure(S_is_nrxysin, g_is_nrxysin_w, 1, 0, 0, H_is_nrxysin, pl_bt);
- Xen_define_typed_procedure(S_make_nrxycos, g_make_nrxycos_w, 0, 0, 1, H_make_nrxycos, pcl_ct);
- Xen_define_typed_procedure(S_nrxycos, g_nrxycos_w, 1, 1, 0, H_nrxycos, pl_dcr);
+ Xen_define_typed_procedure(S_make_nrxycos, g_make_nrxycos_w, 0, 0, 1, H_make_nrxycos,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_nrxycos), t));
+ Xen_define_typed_procedure(S_nrxycos, g_nrxycos_w, 1, 1, 0, H_nrxycos,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_nrxycos), r));
Xen_define_typed_procedure(S_is_nrxycos, g_is_nrxycos_w, 1, 0, 0, H_is_nrxycos, pl_bt);
- Xen_define_typed_procedure(S_make_rxyksin, g_make_rxyksin_w, 0, 0, 1, H_make_rxyksin, pl_ct);
- Xen_define_typed_procedure(S_rxyksin, g_rxyksin_w, 1, 1, 0, H_rxyksin, pl_dcr);
+ Xen_define_typed_procedure(S_make_rxyksin, g_make_rxyksin_w, 0, 0, 1, H_make_rxyksin,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_rxyksin), t));
+ Xen_define_typed_procedure(S_rxyksin, g_rxyksin_w, 1, 1, 0, H_rxyksin,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_rxyksin), r));
Xen_define_typed_procedure(S_is_rxyksin, g_is_rxyksin_w, 1, 0, 0, H_is_rxyksin, pl_bt);
- Xen_define_typed_procedure(S_make_rxykcos, g_make_rxykcos_w, 0, 0, 1, H_make_rxykcos, pcl_ct);
- Xen_define_typed_procedure(S_rxykcos, g_rxykcos_w, 1, 1, 0, H_rxykcos, pl_dcr);
+ Xen_define_typed_procedure(S_make_rxykcos, g_make_rxykcos_w, 0, 0, 1, H_make_rxykcos,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_rxykcos), t));
+ Xen_define_typed_procedure(S_rxykcos, g_rxykcos_w, 1, 1, 0, H_rxykcos,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_rxykcos), r));
Xen_define_typed_procedure(S_is_rxykcos, g_is_rxykcos_w, 1, 0, 0, H_is_rxykcos, pl_bt);
- Xen_define_typed_procedure(S_make_filter, g_make_filter_w, 0, 6, 0, H_make_filter, pcl_ct);
- Xen_define_typed_procedure(S_filter, g_filter_w, 1, 1, 0, H_filter, pl_dcr);
+ Xen_define_typed_procedure(S_make_filter, g_make_filter_w, 0, 6, 0, H_make_filter,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_filter), t));
+ Xen_define_typed_procedure(S_filter, g_filter_w, 1, 1, 0, H_filter,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_filter), r));
Xen_define_typed_procedure(S_is_filter, g_is_filter_w, 1, 0, 0, H_is_filter, pl_bt);
Xen_define_typed_procedure(S_make_fir_coeffs, g_make_fir_coeffs_w, 2, 0, 0, H_make_fir_coeffs, pl_fif);
- Xen_define_typed_procedure(S_make_fir_filter, g_make_fir_filter_w, 0, 4, 0, H_make_fir_filter, pcl_ct);
- Xen_define_typed_procedure(S_fir_filter, g_fir_filter_w, 1, 1, 0, H_fir_filter, pl_dcr);
+ Xen_define_typed_procedure(S_make_fir_filter, g_make_fir_filter_w, 0, 4, 0, H_make_fir_filter,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_fir_filter), t));
+ Xen_define_typed_procedure(S_fir_filter, g_fir_filter_w, 1, 1, 0, H_fir_filter,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_fir_filter), r));
Xen_define_typed_procedure(S_is_fir_filter, g_is_fir_filter_w, 1, 0, 0, H_is_fir_filter, pl_bt);
- Xen_define_typed_procedure(S_make_iir_filter, g_make_iir_filter_w, 0, 4, 0, H_make_iir_filter, pcl_ct);
- Xen_define_typed_procedure(S_iir_filter, g_iir_filter_w, 1, 1, 0, H_iir_filter, pl_dcr);
+ Xen_define_typed_procedure(S_make_iir_filter, g_make_iir_filter_w, 0, 4, 0, H_make_iir_filter,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_iir_filter), t));
+ Xen_define_typed_procedure(S_iir_filter, g_iir_filter_w, 1, 1, 0, H_iir_filter,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_iir_filter), r));
Xen_define_typed_procedure(S_is_iir_filter, g_is_iir_filter_w, 1, 0, 0, H_is_iir_filter, pl_bt);
Xen_define_typed_procedure(S_mus_order, g_mus_order_w, 1, 0, 0, H_mus_order, pl_ic);
Xen_define_typed_procedure(S_mus_type, g_mus_type_w, 1, 0, 0, H_mus_type, pl_ic);
Xen_define_typed_procedure(S_is_env, g_is_env_w, 1, 0, 0, H_is_env, pl_bt);
- Xen_define_typed_procedure(S_env, g_env_w, 1, 0, 0, H_env, pl_dc);
- Xen_define_typed_procedure(S_make_env, g_make_env_w, 0, 0, 1, H_make_env, pcl_ct);
+ Xen_define_typed_procedure(S_env, g_env_w, 1, 0, 0, H_env,
+ s7_make_signature(s7, 2, d, s7_make_symbol(s7, S_is_env)));
+ Xen_define_typed_procedure(S_make_env, g_make_env_w, 0, 0, 1, H_make_env,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_env), t));
Xen_define_typed_procedure(S_env_interp, g_env_interp_w, 2, 0, 0, H_env_interp, pl_drc);
Xen_define_typed_procedure(S_envelope_interp, g_envelope_interp_w, 2, 1, 0, H_envelope_interp, pl_rrpr);
Xen_define_typed_procedure(S_env_any, g_env_any_w, 2, 0, 0, H_env_any, pl_dct);
Xen_define_typed_procedure(S_is_locsig, g_is_locsig_w, 1, 0, 0, H_is_locsig, pl_bt);
- Xen_define_typed_procedure(S_locsig, g_locsig_w, 3, 0, 0, H_locsig, pl_rcr);
- Xen_define_typed_procedure(S_make_locsig, g_make_locsig_w, 0, 0, 1, H_make_locsig, pcl_ct);
+ Xen_define_typed_procedure(S_locsig, g_locsig_w, 3, 0, 0, H_locsig,
+ s7_make_circular_signature(s7, 2, 3, r, s7_make_symbol(s7, S_is_locsig), r));
+ Xen_define_typed_procedure(S_make_locsig, g_make_locsig_w, 0, 0, 1, H_make_locsig,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_locsig), t));
Xen_define_typed_procedure(S_move_locsig, g_move_locsig_w, 3, 0, 0, H_move_locsig, pl_ccrr);
Xen_define_typed_procedure(S_mus_channels, g_mus_channels_w, 1, 0, 0, H_mus_channels, pl_it);
@@ -13003,25 +13079,32 @@ static void mus_xen_init(void)
S_set S_locsig_type, g_set_locsig_type_w, 0, 0, 1, 0, pl_i, pl_i);
Xen_define_typed_procedure(S_is_move_sound, g_is_move_sound_w, 1, 0, 0, H_is_move_sound, pl_bt);
- Xen_define_typed_procedure(S_move_sound, g_move_sound_w, 3, 0, 0, H_move_sound, pl_rcr);
- Xen_define_typed_procedure(S_make_move_sound, g_make_move_sound_w, 1, 2, 0, H_make_move_sound, pcl_ct);
+ Xen_define_typed_procedure(S_move_sound, g_move_sound_w, 3, 0, 0, H_move_sound,
+ s7_make_circular_signature(s7, 2, 3, r, s7_make_symbol(s7, S_is_move_sound), r));
+ Xen_define_typed_procedure(S_make_move_sound, g_make_move_sound_w, 1, 2, 0, H_make_move_sound,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_move_sound), t));
Xen_define_typed_procedure(S_is_file_to_sample, g_is_file_to_sample_w, 1, 0, 0, H_is_file_to_sample, pl_bt);
- Xen_define_typed_procedure(S_make_file_to_sample, g_make_file_to_sample_w, 1, 1, 0, H_make_file_to_sample, pcl_ct);
- Xen_define_typed_procedure(S_file_to_sample, g_file_to_sample_w, 2, 1, 0, H_file_to_sample, pl_dci);
+ Xen_define_typed_procedure(S_make_file_to_sample, g_make_file_to_sample_w, 1, 1, 0, H_make_file_to_sample,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_file_to_sample), t));
+ Xen_define_typed_procedure(S_file_to_sample, g_file_to_sample_w, 2, 1, 0, H_file_to_sample,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_file_to_sample), i));
Xen_define_typed_procedure(S_is_sample_to_file, g_is_sample_to_file_w, 1, 0, 0, H_is_sample_to_file, pl_bt);
- Xen_define_typed_procedure(S_make_sample_to_file, g_make_sample_to_file_w, 1, 4, 0, H_make_sample_to_file, pcl_ct);
+ Xen_define_typed_procedure(S_make_sample_to_file, g_make_sample_to_file_w, 1, 4, 0, H_make_sample_to_file,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_sample_to_file), t));
Xen_define_typed_procedure(S_continue_sample_to_file, g_continue_sample_to_file_w, 1, 0, 0, H_continue_sample_to_file, pl_cs);
Xen_define_typed_procedure(S_sample_to_file, g_sample_to_file_w, 4, 0, 0, H_sample_to_file, pl_rciir);
Xen_define_typed_procedure(S_sample_to_file_add, g_sample_to_file_add_w, 2, 0, 0, H_sample_to_file_add, pl_cc);
Xen_define_typed_procedure(S_is_file_to_frample, g_is_file_to_frample_w, 1, 0, 0, H_is_file_to_frample, pl_bt);
- Xen_define_typed_procedure(S_make_file_to_frample, g_make_file_to_frample_w, 1, 1, 0, H_make_file_to_frample, pcl_ct);
+ Xen_define_typed_procedure(S_make_file_to_frample, g_make_file_to_frample_w, 1, 1, 0, H_make_file_to_frample,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_file_to_frample), t));
Xen_define_typed_procedure(S_file_to_frample, g_file_to_frample_w, 2, 1, 0, H_file_to_frample, pl_ccic);
Xen_define_typed_procedure(S_continue_frample_to_file, g_continue_frample_to_file_w, 1, 0, 0, H_continue_frample_to_file, pl_cs);
Xen_define_typed_procedure(S_is_frample_to_file, g_is_frample_to_file_w, 1, 0, 0, H_is_frample_to_file, pl_bt);
Xen_define_typed_procedure(S_frample_to_file, g_frample_to_file_w, 3, 0, 0, H_frample_to_file, pl_fcif);
- Xen_define_typed_procedure(S_make_frample_to_file, g_make_frample_to_file_w, 1, 4, 0, H_make_frample_to_file, pcl_zt);
+ Xen_define_typed_procedure(S_make_frample_to_file, g_make_frample_to_file_w, 1, 4, 0, H_make_frample_to_file,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_frample_to_file), t));
Xen_define_typed_procedure(S_is_mus_input, g_is_mus_input_w, 1, 0, 0, H_is_mus_input, pl_bt);
Xen_define_typed_procedure(S_is_mus_output, g_is_mus_output_w, 1, 0, 0, H_is_mus_output, pl_bt);
@@ -13040,8 +13123,10 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_is_readin, g_is_readin_w, 1, 0, 0, H_is_readin, pl_bt);
- Xen_define_typed_procedure(S_readin, g_readin_w, 1, 0, 0, H_readin, pl_dc);
- Xen_define_typed_procedure(S_make_readin, g_make_readin_w, 0, 0, 1, H_make_readin, pcl_ct);
+ Xen_define_typed_procedure(S_readin, g_readin_w, 1, 0, 0, H_readin,
+ s7_make_signature(s7, 2, d, s7_make_symbol(s7, S_is_readin)));
+ Xen_define_typed_procedure(S_make_readin, g_make_readin_w, 0, 0, 1, H_make_readin,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_readin), t));
Xen_define_typed_procedure(S_mus_channel, g_mus_channel_w, 1, 0, 0, H_mus_channel, pl_ic);
Xen_define_typed_procedure(S_mus_interp_type, g_mus_interp_type_w, 1, 0, 0, H_mus_interp_type, pl_ic);
@@ -13051,8 +13136,10 @@ static void mus_xen_init(void)
S_set S_mus_increment, g_mus_set_increment_w, 1, 0, 2, 0, pl_dc, pl_dcr);
Xen_define_typed_procedure(S_is_granulate, g_is_granulate_w, 1, 0, 0, H_is_granulate, pl_bt);
- Xen_define_typed_procedure(S_granulate, g_granulate_w, 1, 2, 0, H_granulate, pl_dc);
- Xen_define_typed_procedure(S_make_granulate, g_make_granulate_w, 0, 0, 1, H_make_granulate, pcl_ct);
+ Xen_define_typed_procedure(S_granulate, g_granulate_w, 1, 2, 0, H_granulate,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_granulate), t));
+ Xen_define_typed_procedure(S_make_granulate, g_make_granulate_w, 0, 0, 1, H_make_granulate,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_granulate), t));
Xen_define_typed_dilambda(S_mus_ramp, g_mus_ramp_w, H_mus_ramp,
S_set S_mus_ramp, g_mus_set_ramp_w, 1, 0, 2, 0, pl_dc, pl_dcr);
@@ -13060,18 +13147,24 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_clear_sincs, g_mus_clear_sincs_w, 0, 0, 0, "clears out any sinc tables", NULL);
Xen_define_typed_procedure(S_is_src, g_is_src_w, 1, 0, 0, H_is_src, pl_bt);
- Xen_define_typed_procedure(S_src, g_src_w, 1, 2, 0, H_src, pl_dcrt);
- Xen_define_typed_procedure(S_make_src, g_make_src_w, 0, 6, 0, H_make_src, pcl_ct);
+ Xen_define_typed_procedure(S_src, g_src_w, 1, 2, 0, H_src,
+ s7_make_signature(s7, 4, d, s7_make_symbol(s7, S_is_src), r, t));
+ Xen_define_typed_procedure(S_make_src, g_make_src_w, 0, 6, 0, H_make_src,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_src), t));
Xen_define_typed_procedure(S_is_convolve, g_is_convolve_w, 1, 0, 0, H_is_convolve, pl_bt);
- Xen_define_typed_procedure(S_convolve, g_convolve_w, 1, 1, 0, H_convolve_gen, pl_dc);
- Xen_define_typed_procedure(S_make_convolve, g_make_convolve_w, 0, 0, 1, H_make_convolve, pcl_ct);
+ Xen_define_typed_procedure(S_convolve, g_convolve_w, 1, 1, 0, H_convolve_gen,
+ s7_make_signature(s7, 3, d, s7_make_symbol(s7, S_is_convolve), t));
+ Xen_define_typed_procedure(S_make_convolve, g_make_convolve_w, 0, 0, 1, H_make_convolve,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_convolve), t));
Xen_define_typed_procedure(S_convolve_files, g_convolve_files_w, 2, 2, 0, H_convolve_files, pl_sssrs);
Xen_define_typed_procedure(S_is_phase_vocoder, g_is_phase_vocoder_w, 1, 0, 0, H_is_phase_vocoder, pl_bt);
- Xen_define_typed_procedure(S_phase_vocoder, g_phase_vocoder_w, 1, 4, 0, H_phase_vocoder, pl_dc);
- Xen_define_typed_procedure(S_make_phase_vocoder, g_make_phase_vocoder_w, 0, 0, 1, H_make_phase_vocoder, pcl_ct);
+ Xen_define_typed_procedure(S_phase_vocoder, g_phase_vocoder_w, 1, 4, 0, H_phase_vocoder,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_phase_vocoder), t));
+ Xen_define_typed_procedure(S_make_phase_vocoder, g_make_phase_vocoder_w, 0, 0, 1, H_make_phase_vocoder,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_phase_vocoder), t));
Xen_define_typed_procedure(S_phase_vocoder_amp_increments, g_phase_vocoder_amp_increments_w, 1, 0, 0, H_phase_vocoder_amp_increments, pl_fc);
Xen_define_typed_procedure(S_phase_vocoder_amps, g_phase_vocoder_amps_w, 1, 0, 0, H_phase_vocoder_amps, pl_fc);
Xen_define_typed_procedure(S_phase_vocoder_freqs, g_phase_vocoder_freqs_w, 1, 0, 0, H_phase_vocoder_freqs, pl_fc);
@@ -13081,8 +13174,10 @@ static void mus_xen_init(void)
Xen_define_typed_dilambda(S_mus_hop, g_mus_hop_w, H_mus_hop,
S_set S_mus_hop, g_mus_set_hop_w, 1, 0, 2, 0, pl_dc, pl_dcr);
- Xen_define_typed_procedure(S_make_ssb_am, g_make_ssb_am_w, 0, 4, 0, H_make_ssb_am, pcl_ct);
- Xen_define_typed_procedure(S_ssb_am, g_ssb_am_w, 1, 2, 0, H_ssb_am, pl_dcr);
+ Xen_define_typed_procedure(S_make_ssb_am, g_make_ssb_am_w, 0, 4, 0, H_make_ssb_am,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_ssb_am), t));
+ Xen_define_typed_procedure(S_ssb_am, g_ssb_am_w, 1, 2, 0, H_ssb_am,
+ s7_make_circular_signature(s7, 2, 3, d, s7_make_symbol(s7, S_is_ssb_am), r));
Xen_define_typed_procedure(S_is_ssb_am, g_is_ssb_am_w, 1, 0, 0, H_is_ssb_am, pl_bt);
Xen_define_typed_procedure(S_is_mus_generator, g_is_mus_generator_w, 1, 0, 0, H_is_mus_generator, pl_bt);
@@ -13117,11 +13212,16 @@ static void mus_xen_init(void)
Xen_define_typed_procedure(S_singer_nose_filter, g_singer_nose_filter_w, 5, 0, 0, H_singer_nose_filter, pl_rirfff);
#endif
- Xen_define_typed_procedure(S_make_oscil, g_make_oscil_w, 0, 4, 0, H_make_oscil, pcl_ct);
- Xen_define_typed_procedure(S_make_ncos, g_make_ncos_w, 0, 4, 0, H_make_ncos, pcl_ct);
- Xen_define_typed_procedure(S_make_oscil_bank, g_make_oscil_bank_w, 2, 2, 0, H_make_oscil_bank, pcl_ct);
- Xen_define_typed_procedure(S_make_nsin, g_make_nsin_w, 0, 4, 0, H_make_nsin, pcl_ct);
- Xen_define_typed_procedure(S_make_asymmetric_fm, g_make_asymmetric_fm_w, 0, 8, 0, H_make_asymmetric_fm, pcl_ct);
+ Xen_define_typed_procedure(S_make_oscil, g_make_oscil_w, 0, 4, 0, H_make_oscil,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_oscil), t));
+ Xen_define_typed_procedure(S_make_ncos, g_make_ncos_w, 0, 4, 0, H_make_ncos,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_ncos), t));
+ Xen_define_typed_procedure(S_make_oscil_bank, g_make_oscil_bank_w, 2, 2, 0, H_make_oscil_bank,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_oscil_bank), t));
+ Xen_define_typed_procedure(S_make_nsin, g_make_nsin_w, 0, 4, 0, H_make_nsin,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_nsin), t));
+ Xen_define_typed_procedure(S_make_asymmetric_fm, g_make_asymmetric_fm_w, 0, 8, 0, H_make_asymmetric_fm,
+ s7_make_circular_signature(s7, 1, 2, s7_make_symbol(s7, S_is_asymmetric_fm), t));
Xen_define_typed_procedure(S_mus_file_mix, g_mus_file_mix_w, 0, 0, 1, H_mus_file_mix, NULL);
Xen_define_typed_procedure(S_mus_file_mix_with_envs, g_mus_file_mix_with_envs_w, 0, 0, 1, H_mus_file_mix_with_envs, NULL); /* actually 8 2 0 I think */
diff --git a/cload.scm b/cload.scm
index 5898fc8..728a05d 100644
--- a/cload.scm
+++ b/cload.scm
@@ -126,14 +126,6 @@
;; function info is either a list: (return-type c-name arg-type) or a list thereof
;; the new functions are placed in cur-env
- (define collides?
- (let ((all-names ()))
- (lambda (name)
- (if (member name all-names eq?)
- (format *stderr* "~A twice?~%" name)
- (set! all-names (cons name all-names)))
- name)))
-
(define handlers (list '(integer s7_is_integer s7_integer s7_make_integer s7_int)
'(boolean s7_is_boolean s7_boolean s7_make_boolean bool)
'(real s7_is_real s7_number_to_real s7_make_real s7_double)
@@ -148,17 +140,10 @@
'(s7_pointer #f #f #f s7_pointer)
))
- (define (find-handler handle choice)
- (let ((found (assoc handle handlers eq?)))
- (if (pair? found)
- (choice found)
- #t)))
-
-
(define (C-type->s7-type type)
(if (pair? type) ; in case the type name does not make its C type obvious: (graph_style_t int)
- (symbol->string (cadr type))
+ (C-type->s7-type (cadr type))
(let ((type-name (symbol->string type)))
(cond ((string-position "**" type-name) ; any complicated C pointer is uninterpreted
'c_pointer)
@@ -173,11 +158,9 @@
(string-position "pointer" type-name))
'c_pointer)
- ((string-position "char" type-name)
- 'character)
-
- ((string-position "bool" type-name)
- 'boolean)
+ ((assoc type-name '(("char" . character)
+ ("bool" . boolean)) string-position)
+ => cdr)
;; ((string-position "complex" type-name)
;; 'complex) ; double complex or complex double (mus_edot_product in clm.c uses the latter)
@@ -195,19 +178,22 @@
(#t #t)))))
+ (define (find-handler type choice)
+ (cond ((assq (C-type->s7-type type) handlers) => choice) (else #t)))
+
(define (C->s7-cast type)
- (find-handler (C-type->s7-type type) (lambda (p) (car (cddddr p)))))
+ (find-handler type (lambda (p) (list-ref p 4))))
(define (C->s7 type)
- (find-handler (C-type->s7-type type) cadddr))
+ (find-handler type cadddr))
(define (s7->C type)
- (find-handler (C-type->s7-type type) caddr))
+ (find-handler type caddr))
(define (checker type)
- (find-handler (C-type->s7-type type) cadr))
+ (find-handler type cadr))
- (define* (cload->signature type (rtn #f))
+ (define* (cload->signature type rtn)
(case (C-type->s7-type type)
((real) (if rtn 'float? 'real?))
((integer) 'integer?)
@@ -230,11 +216,11 @@
(set! c-define-output-file-counter (+ c-define-output-file-counter 1))
- (let* ((file-name (string-append *cload-directory* (or output-name (format "temp-s7-output-~D" c-define-output-file-counter))))
+ (let* ((file-name (string-append *cload-directory* (or output-name (format #f "temp-s7-output-~D" c-define-output-file-counter))))
(c-file-name (string-append file-name ".c"))
(o-file-name (string-append file-name ".o"))
(so-file-name (string-append file-name ".so"))
- (init-name (if output-name
+ (init-name (if (string? output-name)
(string-append output-name "_init")
(string-append "init_" (number->string c-define-output-file-counter))))
(functions ())
@@ -267,7 +253,7 @@
(set! sig (compress sig))
(set! cyclic (not (= len (length sig)))))
(set! sig (reverse sig))
- (when (not (signatures sig)) ; it's not in our collection yet
+ (unless (signatures sig) ; it's not in our collection yet
(let ((pl (make-string (+ (if cyclic 4 3) (length sig))))
(loc (if cyclic 4 3)))
(set! (pl 0) #\p)
@@ -277,8 +263,8 @@
(for-each
(lambda (typer)
(set! (pl loc) (signature->pl typer))
- (let ((count (or (assoc typer sig-symbols eq?)
- (assoc 't sig-symbols eq?))))
+ (let ((count (or (assq typer sig-symbols)
+ (assq 't sig-symbols))))
(set-cdr! count (+ (cdr count) 1)))
(set! loc (+ loc 1)))
sig)
@@ -299,6 +285,13 @@
headers))
(format p "#include \"s7.h\"~%~%"))
+ (define collides?
+ (let ((all-names ()))
+ (lambda (name)
+ (if (memq name all-names)
+ (format *stderr* "~A twice?~%" name)
+ (set! all-names (cons name all-names)))
+ name)))
(define* (add-one-function return-type name arg-types doc)
;; (format *stderr* "~A ~A ~A~%" return-type name arg-types): double j0 (double) for example
@@ -316,39 +309,38 @@
(format p "{~%")
;; get the Scheme args, check their types, assign to local C variables
- (if (positive? num-args)
- (begin
- (format p " s7_pointer arg;~%")
- (do ((i 0 (+ i 1))
- (type arg-types (cdr type)))
- ((= i num-args))
- (format p " ~A ~A_~D;~%" (if (pair? (car type)) (caar type) (car type)) base-name i))
- (format p " arg = args;~%")
- (do ((i 0 (+ i 1))
- (type arg-types (cdr type)))
- ((= i num-args))
-
- (let* ((nominal-type (if (pair? (car type)) (caar type) (car type))) ; double in the example
- (true-type (if (pair? (car type)) (cadar type) (car type)))
- (s7-type (C-type->s7-type true-type))) ; real
- (if (eq? true-type 's7_pointer)
- (format p " ~A_~D = s7_car(arg);~%" base-name i)
- (begin
- (format p " if (~A(s7_car(arg)))~%" (checker true-type))
- (format p " ~A_~D = (~A)~A(~As7_car(arg));~%"
- base-name i
- nominal-type
- (s7->C true-type) ; s7_number_to_real which requires
- (if (member s7-type '(boolean real) eq?) ; the extra sc arg
- "sc, " ""))
- (format p " else return(s7_wrong_type_arg_error(sc, ~S, ~D, s7_car(arg), ~S));~%"
- func-name
- (if (= num-args 1) 0 (+ i 1))
- (if (symbol? s7-type)
- (symbol->string s7-type)
- (error 'bad-arg (format #f "in ~S, ~S is not a symbol~%" name s7-type))))))
- (if (< i (- num-args 1))
- (format p " arg = s7_cdr(arg);~%"))))))
+ (when (positive? num-args)
+ (format p " s7_pointer arg;~%")
+ (do ((i 0 (+ i 1))
+ (type arg-types (cdr type)))
+ ((= i num-args))
+ (format p " ~A ~A_~D;~%" ((if (pair? (car type)) caar car) type) base-name i))
+ (format p " arg = args;~%")
+ (do ((i 0 (+ i 1))
+ (type arg-types (cdr type)))
+ ((= i num-args))
+
+ (let* ((nominal-type ((if (pair? (car type)) caar car) type)) ; double in the example
+ (true-type ((if (pair? (car type)) cadar car) type))
+ (s7-type (C-type->s7-type true-type))) ; real
+ (if (eq? true-type 's7_pointer)
+ (format p " ~A_~D = s7_car(arg);~%" base-name i)
+ (begin
+ (format p " if (~A(s7_car(arg)))~%" (checker true-type))
+ (format p " ~A_~D = (~A)~A(~As7_car(arg));~%"
+ base-name i
+ nominal-type
+ (s7->C true-type) ; s7_number_to_real which requires
+ (if (memq s7-type '(boolean real)) ; the extra sc arg
+ "sc, " ""))
+ (format p " else return(s7_wrong_type_arg_error(sc, ~S, ~D, s7_car(arg), ~S));~%"
+ func-name
+ (if (= num-args 1) 0 (+ i 1))
+ (if (symbol? s7-type)
+ (symbol->string s7-type)
+ (error 'bad-arg (format #f "in ~S, ~S is not a symbol~%" name s7-type))))))
+ (if (< i (- num-args 1))
+ (format p " arg = s7_cdr(arg);~%")))))
;; return C value to Scheme
(if (pair? return-type)
@@ -368,9 +360,9 @@
(format p ")")
(if (symbol? return-translator)
(format p ")"))
- (if (not (eq? return-translator #t))
- (format p ");~%")
- (format p ";~% return(s7_unspecified(sc));~%"))
+ (format p (if (not (eq? return-translator #t))
+ ");~%"
+ ";~% return(s7_unspecified(sc));~%"))
(format p "}~%"))
;; add optimizer connection
@@ -380,19 +372,18 @@
(and (= num-args 2) ; double (f double double)
(eq? (cadr arg-types) 'double))))
(set! rf-funcs (cons (cons func-name scheme-name) rf-funcs))
- (if (= num-args 1)
- (format p "static s7_double ~A_rf_r(s7_scheme *sc, s7_pointer **p)~
+ (format p (if (= num-args 1)
+ "static s7_double ~A_rf_r(s7_scheme *sc, s7_pointer **p)~
{s7_rf_t f; s7_double x; f = (s7_rf_t)(**p); (*p)++; x = f(sc, p); return(~A(x));}~%"
- func-name func-name)
- (format p "static s7_double ~A_rf_r(s7_scheme *sc, s7_pointer **p)~% ~
- {s7_rf_t f; s7_double x, y; f = (s7_rf_t)(**p); (*p)++; x = f(sc, p); f = (s7_rf_t)(**p); (*p)++; y = f(sc, p); return(~A(x, y));}~%"
- func-name func-name))
+ "static s7_double ~A_rf_r(s7_scheme *sc, s7_pointer **p)~% ~
+ {s7_rf_t f; s7_double x, y; f = (s7_rf_t)(**p); (*p)++; x = f(sc, p); f = (s7_rf_t)(**p); (*p)++; y = f(sc, p); return(~A(x, y));}~%")
+ func-name func-name)
(format p "static s7_rf_t ~A_rf(s7_scheme *sc, s7_pointer expr) ~
{if (s7_arg_to_rf(sc, s7_cadr(expr))) return(~A_rf_r); return(NULL);}~%"
func-name func-name))
(when (and (eq? return-type 'int) ; int (f int|double|void)
- (member (car arg-types) '(int double void) eq?)
+ (memq (car arg-types) '(int double void))
(<= num-args 1))
(set! if-funcs (cons (cons func-name scheme-name) if-funcs))
(case (car arg-types)
@@ -425,28 +416,6 @@
functions))))
- (define (add-one-constant type name)
- ;; C constant -> scheme
- (let ((c-type (if (pair? type) (cadr type) type)))
- (if (symbol? name)
- (set! constants (cons (list c-type (symbol->string (collides? name))) constants))
- (for-each
- (lambda (c)
- (set! constants (cons (list c-type (symbol->string (collides? c))) constants)))
- name))))
-
-
- (define (add-one-macro type name)
- ;; C macro (with definition check) -> scheme
- (let ((c-type (if (pair? type) (cadr type) type)))
- (if (symbol? name)
- (set! macros (cons (list c-type (symbol->string (collides? name))) macros))
- (for-each
- (lambda (c)
- (set! macros (cons (list c-type (symbol->string (collides? c))) macros)))
- name))))
-
-
(define (end-c-file)
;; now the init function
;; the new scheme variables and functions are placed in the current environment
@@ -460,7 +429,7 @@
(loc 1))
(for-each
(lambda (s)
- (format p "~A~A~A" (cdr s) (if (< loc pls) "," ";") (if (< loc pls) " " #\newline))
+ (format p "~A~A~A" (cdr s) (if (< loc pls) (values "," " ") (values ";" #\newline)))
(set! loc (+ loc 1)))
signatures))
@@ -479,19 +448,18 @@
(if (eq? sym 't)
(format p " t = s7_t(sc);~%")
(format p " ~C = s7_make_symbol(sc, ~S);~%" name (symbol->string sym))))
- names syms))
- (format p "~%")
- (for-each
- (lambda (sig)
- (let ((cyclic (char=? ((cdr sig) 1) #\c)))
- (if cyclic
- (format p " ~A = s7_make_circular_signature(sc, ~D, ~D" (cdr sig) (- (length (car sig)) 1) (length (car sig)))
- (format p " ~A = s7_make_signature(sc, ~D" (cdr sig) (length (car sig))))
- (format p "~{~^, ~C~}" (substring (cdr sig) (if cyclic 4 3)))
- (format p ");~%")))
- signatures)
- (format p " }~%~%"))
-
+ names syms)))
+ (format p "~%")
+ (for-each
+ (lambda (sig)
+ (let ((cyclic (char=? ((cdr sig) 1) #\c)))
+ (if cyclic
+ (format p " ~A = s7_make_circular_signature(sc, ~D, ~D" (cdr sig) (- (length (car sig)) 1) (length (car sig)))
+ (format p " ~A = s7_make_signature(sc, ~D" (cdr sig) (length (car sig))))
+ (format p "~{~^, ~C~}" (substring (cdr sig) (if cyclic 4 3)))
+ (format p ");~%")))
+ signatures)
+ (format p " }~%~%")
(format p " cur_env = s7_outlet(sc, s7_curlet(sc));~%") ; this must exist because we pass load the env ourselves
;; send out any special initialization code
@@ -573,42 +541,68 @@
;; now we have the module .c file -- make it into a shared object, load it, delete the temp files
- (if (provided? 'osx)
- (begin
- ;; I assume the caller is also compiled with these flags?
- (system (format #f "gcc -c ~A -o ~A ~A"
- c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
- (system (format #f "gcc ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A"
- o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))
-
- (if (provided? 'freebsd)
- (begin
- (system (format #f "cc -fPIC -c ~A -o ~A ~A"
- c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
- (system (format #f "cc ~A -shared -o ~A ~A"
- o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))
-
- (if (provided? 'openbsd)
- (begin
- (system (format #f "cc -fPIC -ftrampolines -c ~A -o ~A ~A"
- c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
- (system (format #f "cc ~A -shared -o ~A ~A"
- o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))
-
- (begin
- (system (format #f "gcc -fPIC -c ~A -o ~A ~A"
- c-file-name o-file-name (string-append *cload-cflags* " " cflags)))
- (system (format #f "gcc ~A -shared -o ~A ~A"
- o-file-name so-file-name (string-append *cload-ldflags* " " ldflags))))))))
-
- (define (check-doc func-data)
- (let ((doc (caddr func-data)))
- (if (and (string? doc)
- (> (length doc) 0))
- func-data
- (append (list (car func-data) (cadr func-data) (car func-data)) (cdddr func-data)))))
+ (cond ((provided? 'osx)
+ ;; I assume the caller is also compiled with these flags?
+ (system (format #f "gcc -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "gcc ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((provided? 'freebsd)
+ (system (format #f "cc -fPIC -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "cc ~A -shared -o ~A ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((provided? 'openbsd)
+ (system (format #f "cc -fPIC -ftrampolines -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "cc ~A -shared -o ~A ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((provided? 'sunpro_c) ; just guessing here...
+ (system (format #f "cc -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "cc ~A -G -o ~A ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ;; what about clang? Maybe use cc below, not gcc (and in osx case above)
+
+ (else
+ (system (format #f "gcc -fPIC -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "gcc ~A -shared -o ~A ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))))
(define (handle-declaration func)
+
+ (define (add-one-constant type name)
+ ;; C constant -> scheme
+ (let ((c-type (if (pair? type) (cadr type) type)))
+ (if (symbol? name)
+ (set! constants (cons (list c-type (symbol->string (collides? name))) constants))
+ (for-each
+ (lambda (c)
+ (set! constants (cons (list c-type (symbol->string (collides? c))) constants)))
+ name))))
+
+ (define (add-one-macro type name)
+ ;; C macro (with definition check) -> scheme
+ (let ((c-type (if (pair? type) (cadr type) type)))
+ (if (symbol? name)
+ (set! macros (cons (list c-type (symbol->string (collides? name))) macros))
+ (for-each
+ (lambda (c)
+ (set! macros (cons (list c-type (symbol->string (collides? c))) macros)))
+ name))))
+
+ (define (check-doc func-data)
+ (let ((doc (caddr func-data)))
+ (if (and (string? doc)
+ (> (length doc) 0))
+ func-data
+ (append (list (car func-data) (cadr func-data) (car func-data)) (cdddr func-data)))))
+
;; functions
(if (>= (length func) 3)
(apply add-one-function func)
diff --git a/configure b/configure
index ad64317..2ea88a6 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.69 for snd 16.5.
+# Generated by GNU Autoconf 2.69 for snd 16.6.
#
# Report bugs to <bil at ccrma.stanford.edu>.
#
@@ -580,8 +580,8 @@ MAKEFLAGS=
# Identity of this package.
PACKAGE_NAME='snd'
PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-16.tar.gz'
-PACKAGE_VERSION='16.5'
-PACKAGE_STRING='snd 16.5'
+PACKAGE_VERSION='16.6'
+PACKAGE_STRING='snd 16.6'
PACKAGE_BUGREPORT='bil at ccrma.stanford.edu'
PACKAGE_URL=''
@@ -1310,7 +1310,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures snd 16.5 to adapt to many kinds of systems.
+\`configure' configures snd 16.6 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1380,7 +1380,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of snd 16.5:";;
+ short | recursive ) echo "Configuration of snd 16.6:";;
esac
cat <<\_ACEOF
@@ -1496,7 +1496,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-snd configure 16.5
+snd configure 16.6
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
@@ -1957,7 +1957,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by snd $as_me 16.5, which was
+It was created by snd $as_me 16.6, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
@@ -3304,7 +3304,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
-VERSION=16.5
+VERSION=16.6
#--------------------------------------------------------------------------------
# configuration options
@@ -6691,7 +6691,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by snd $as_me 16.5, which was
+This file was extended by snd $as_me 16.6, which was
generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -6753,7 +6753,7 @@ _ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-snd config.status 16.5
+snd config.status 16.6
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
diff --git a/configure.ac b/configure.ac
index 58f8703..a15ab4a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@
# gmp, mpfr, and mpc deliberately have none!
-AC_INIT(snd, 16.5, bil at ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-16.tar.gz)
+AC_INIT(snd, 16.6, bil at ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-16.tar.gz)
AC_CONFIG_SRCDIR(snd.c)
AC_CANONICAL_HOST # needed by case $host below
@@ -24,7 +24,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
-VERSION=16.5
+VERSION=16.6
#--------------------------------------------------------------------------------
# configuration options
diff --git a/dlocsig.scm b/dlocsig.scm
index a59f61e..aaac828 100644
--- a/dlocsig.scm
+++ b/dlocsig.scm
@@ -225,7 +225,7 @@
(else (has-duplicates? (cdr lst)))))
(define (invert3x3 mat) ; invert a 3x3 matrix using cofactors
- (let ((m (make-float-vector (list 3 3) 0.0))
+ (let ((m (make-float-vector '(3 3)))
(det 0.0)
(invdet 0.0))
(do ((i 0 (+ i 1)))
@@ -256,7 +256,7 @@
mat))))
(define (invert2x2 mat) ; invert a 2x2 matrix
- (let ((m (make-float-vector (list 2 2) 0.0))
+ (let ((m (make-float-vector '(2 2)))
(det (- (* (mat 0 0) (mat 1 1))
(* (mat 1 0) (mat 0 1)))))
(and (> (abs det) 1e-06)
@@ -337,9 +337,9 @@
(lambda (s) ; speakers
(let* ((a (if (pair? s) (car s) s))
(e (if (pair? s) (or (cadr s) 0.0) 0.0))
- (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
+ (evec (cis (/ (* e 2 pi) dlocsig-one-turn)))
(dxy (real-part evec))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi)))
+ (avec (cis (/ (* a 2 pi) dlocsig-one-turn)))
(x (* dxy (imag-part avec)))
(y (* dxy (real-part avec)))
(z (imag-part evec))
@@ -360,7 +360,7 @@
(set! (v i) (let ((distance (and (pair? distances) (distances i)))
(dly (and (pair? delays) (delays i))))
(or dly
- (and distance
+ (and (number? distance)
(/ (- distance min-dist) dlocsig-speed-of-sound))
0.0))))
v))
@@ -373,7 +373,7 @@
(let* ((size (length group))
(vertices (map coords group))
(matrix (if (= size 3)
- (let ((m (make-float-vector (list 3 3) 0.0)))
+ (let ((m (make-float-vector '(3 3))))
(do ((i 0 (+ i 1)))
((= i 3))
(do ((j 0 (+ j 1)))
@@ -381,7 +381,7 @@
(set! (m i j) ((vertices i) j))))
(invert3x3 m))
(and (= size 2)
- (let ((m (make-float-vector (list 2 2) 0.0)))
+ (let ((m (make-float-vector '(2 2))))
(do ((i 0 (+ i 1)))
((= i 2))
(do ((j 0 (+ j 1)))
@@ -501,9 +501,7 @@
(define set-speaker-configuration
(let ((documentation "(set-speaker-configuration config (configs dlocsig-speaker-configs)) sets a dlocsig speaker configuration"))
(lambda* (config (configs dlocsig-speaker-configs))
- (let ((lst (if (< (speaker-config-dimension config) 3)
- (car configs)
- (cadr configs)))
+ (let ((lst ((if (< (speaker-config-dimension config) 3) car cadr) configs))
(num (speaker-config-number config)))
(set! (lst num) config)))))
@@ -864,10 +862,7 @@
(set! x (cons (car p) x))
(set! y (cons (cadr p) y))
(set! z (cons (if 3d (or (third p) 0.0) 0.0) z))
- (set! v (cons (if 3d
- (fourth p)
- (third p))
- v)))
+ (set! v (cons ((if 3d fourth third) p) v)))
points)
(list (reverse x) (reverse y) (reverse z) (reverse v)))
@@ -924,13 +919,13 @@
(let* ((d (car p))
(a (cadr p))
(e (if (and 3d (pair? (cddr p))) (caddr p) 0.0))
- (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
+ (evec (cis (/ (* e 2 pi) dlocsig-one-turn)))
(dxy (* d (real-part evec)))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
+ (avec (cis (/ (* a 2 pi) dlocsig-one-turn))))
(set! x (cons (* dxy (imag-part avec)) x))
(set! y (cons (* dxy (real-part avec)) y))
(set! z (cons (* d (imag-part evec)) z))
- (set! v (cons (if 3d (fourth p) (third p)) v))))
+ (set! v (cons ((if 3d fourth third) p) v))))
points)
(list (reverse x) (reverse y) (reverse z) (reverse v)))
@@ -949,9 +944,9 @@
(let* ((d (points i))
(a (points (+ i 1)))
(e (points (+ i 2)))
- (evec (cis (* (/ e dlocsig-one-turn) 2 pi)))
+ (evec (cis (/ (* e 2 pi) dlocsig-one-turn)))
(dxy (* d (real-part evec)))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
+ (avec (cis (/ (* a 2 pi) dlocsig-one-turn))))
(set! x (cons (* dxy (imag-part avec)) x))
(set! y (cons (* dxy (real-part avec)) y))
(set! z (cons (* d (imag-part evec)) z))))
@@ -966,7 +961,7 @@
(list (reverse x) (reverse y) (make-list (length x) 0.0) (make-list (length x) #f)))
(let* ((d (points i))
(a (points (+ i 1)))
- (avec (cis (* (/ a dlocsig-one-turn) 2 pi))))
+ (avec (cis (/ (* a 2 pi) dlocsig-one-turn))))
(set! x (cons (* d (imag-part avec)) x))
(set! y (cons (* d (real-part avec)) y)))))))))))
@@ -990,7 +985,7 @@
(set! (bezier-v xpath) (cadddr vals)))))
(for-each
(lambda (v)
- (if (and (number? v)
+ (if (and (real? v)
(< v 0))
(error 'mus-error "velocities for path ~A must be all positive~%" (bezier-path xpath))))
(bezier-v xpath))
@@ -1029,8 +1024,7 @@
(ym1 (- py y0))
(zm1 (- pz z0))
(p (* (distance xm1 ym1 zm1) (vcos xm0 ym0 zm0 xm1 ym1 zm1)))
- (k (distance xm0 ym0 zm0))
- (ratio (/ p k)))
+ (ratio (/ p (distance xm0 ym0 zm0))))
(list (+ x0 (* xm0 ratio))
(+ y0 (* ym0 ratio))
(+ z0 (* zm0 ratio)))))))
@@ -1042,20 +1036,18 @@
(define path-maxcoeff 8)
(define (make-a-even)
-
- (define g
- (let ((path-gtab #f))
- (lambda (m)
- (if (not path-gtab)
- (begin
- (set! path-gtab (make-vector path-maxcoeff))
- (set! (path-gtab 0) 1)
- (set! (path-gtab 1) -4)
- (do ((i 2 (+ i 1)))
- ((= i path-maxcoeff))
- (set! (path-gtab i) (- (* -4 (path-gtab (- i 1)))
- (path-gtab (- i 2)))))))
- (path-gtab m))))
+ (let ((g (let ((path-gtab #f))
+ (lambda (m)
+ (if (not path-gtab)
+ (begin
+ (set! path-gtab (make-vector path-maxcoeff))
+ (set! (path-gtab 0) 1)
+ (set! (path-gtab 1) -4)
+ (do ((i 2 (+ i 1)))
+ ((= i path-maxcoeff))
+ (set! (path-gtab i) (- (* -4 (path-gtab (- i 1)))
+ (path-gtab (- i 2)))))))
+ (path-gtab m)))))
(set! path-ak-even (make-vector (- path-maxcoeff 1)))
(do ((m 1 (+ 1 m)))
@@ -1063,23 +1055,21 @@
(set! (path-ak-even (- m 1)) (make-vector m))
(do ((k 1 (+ k 1)))
((> k m))
- (set! ((path-ak-even (- m 1)) (- k 1)) (* 1.0 (/ (- (g (- m k))) (g m)))))))
+ (set! ((path-ak-even (- m 1)) (- k 1)) (* 1.0 (/ (- (g (- m k))) (g m))))))))
(define (make-a-odd)
-
- (define f
- (let ((path-ftab #f))
- (lambda (m)
- (if (not path-ftab)
- (begin
- (set! path-ftab (make-vector path-maxcoeff))
- (set! (path-ftab 0) 1)
- (set! (path-ftab 1) -3)
- (do ((i 2 (+ i 1)))
- ((= i path-maxcoeff))
- (set! (path-ftab i) (- (* -4 (path-ftab (- i 1)))
- (path-ftab (- i 2)))))))
- (path-ftab m))))
+ (let ((f (let ((path-ftab #f))
+ (lambda (m)
+ (if (not path-ftab)
+ (begin
+ (set! path-ftab (make-vector path-maxcoeff))
+ (set! (path-ftab 0) 1)
+ (set! (path-ftab 1) -3)
+ (do ((i 2 (+ i 1)))
+ ((= i path-maxcoeff))
+ (set! (path-ftab i) (- (* -4 (path-ftab (- i 1)))
+ (path-ftab (- i 2)))))))
+ (path-ftab m)))))
(set! path-ak-odd (make-vector (- path-maxcoeff 1)))
(do ((m 1 (+ 1 m)))
@@ -1087,7 +1077,7 @@
(set! (path-ak-odd (- m 1)) (make-vector m))
(do ((k 1 (+ k 1)))
((> k m))
- (set! ((path-ak-odd (- m 1)) (- k 1)) (* 1.0 (/ (- (f (- m k))) (f m)))))))
+ (set! ((path-ak-odd (- m 1)) (- k 1)) (* 1.0 (/ (- (f (- m k))) (f m))))))))
;;; Calculate bezier difference vectors for the given path
;;; (path-x (make-path '((-10 10)(0 5)(10 10))))
@@ -1115,11 +1105,10 @@
((path-ak-even (/ (- n 4) 2)) (- k 1)))))
(define (xvector-ref z j i)
- (if (> i (- n 1))
- ((z j) (- i n))
- (if (< i 0)
- ((z j) (+ i n))
- ((z j) i))))
+ (z j (if (> i (- n 1))
+ (- i n)
+ (if (< i 0)
+ (+ i n) i))))
(do ((i 0 (+ i 1)))
((= i n))
@@ -1127,17 +1116,17 @@
((> k m))
(do ((a 0 (+ 1 a)))
((> a 2))
- (set! ((d a) i)
- (+ ((d a) i)
+ (set! (d a i)
+ (+ (d a i)
(* (a-1 k n)
(- (xvector-ref p a (+ i k))
(xvector-ref p a (- i k)))))))))
(if (bezier-curvature path)
(do ((i 0 (+ i 1)))
((= i n))
- (set! ((d 0) i) (* ((d 0) i) (bezier-curvature path)))
- (set! ((d 1) i) (* ((d 1) i) (bezier-curvature path)))
- (set! ((d 2) i) (* ((d 2) i) (bezier-curvature path)))))
+ (set! (d 0 i) (* (d 0 i) (bezier-curvature path)))
+ (set! (d 1 i) (* (d 1 i) (bezier-curvature path)))
+ (set! (d 2 i) (* (d 2 i) (bezier-curvature path)))))
(list (- n 1) p d)))
(else
(let* ((n (- (length (bezier-x path)) 1))
@@ -1157,54 +1146,51 @@
((path-ak-even (- un 2)) (- k 1))))
(define (ref z j i)
- (cond ((> i n) ((z j) (- i n)))
- ((< i 0) ((z j) (+ i n)))
- ((= i n) (- ((z j) n) ((d j) n)))
- ((= i 0) (+ ((z j) 0) ((d j) 0)))
- (else ((z j) i))))
+ (cond ((> i n) (z j (- i n)))
+ ((< i 0) (z j (+ i n)))
+ ((= i n) (- (z j n) (d j n)))
+ ((= i 0) (+ (z j 0) (d j 0)))
+ (else (z j i))))
;; forced initial direction
(if (initial-direction path)
(begin
- (set! ((d 0) 0) (car (initial-direction path)))
- (set! ((d 1) 0) (cadr (initial-direction path)))
- (set! ((d 2) 0) (third (initial-direction path))))
+ (set! (d 0 0) (car (initial-direction path)))
+ (set! (d 1 0) (cadr (initial-direction path)))
+ (set! (d 2 0) (third (initial-direction path))))
(begin
- (set! ((d 0) 0) 0.0)
- (set! ((d 1) 0) 0.0)
- (set! ((d 2) 0) 0.0)))
+ (set! (d 0 0) 0.0)
+ (set! (d 1 0) 0.0)
+ (set! (d 2 0) 0.0)))
;; forced final direction
(if (final-direction path)
(begin
- (set! ((d 0) n) (car (final-direction path)))
- (set! ((d 1) n) (cadr (final-direction path)))
- (set! ((d 2) n) (caddr (final-direction path))))
+ (set! (d 0 n) (car (final-direction path)))
+ (set! (d 1 n) (cadr (final-direction path)))
+ (set! (d 2 n) (caddr (final-direction path))))
(begin
- (set! ((d 0) n) 0.0)
- (set! ((d 1) n) 0.0)
- (set! ((d 2) n) 0.0)))
+ (set! (d 0 n) 0.0)
+ (set! (d 1 n) 0.0)
+ (set! (d 2 n) 0.0)))
;; calculate fit
(do ((i 1 (+ i 1)))
((= i n))
(do ((k 1 (+ k 1)))
((> k (min m (- path-maxcoeff 1))))
- (let ((d0 ((d 0) i))
- (d1 ((d 1) i))
- (d2 ((d 2) i)))
- (set! ((d 0) i) (+ d0
- (* (ac k n)
- (- (ref p 0 (+ i k))
- (ref p 0 (- i k))))))
- (set! ((d 1) i) (+ d1
- (* (ac k n)
- (- (ref p 1 (+ i k))
- (ref p 1 (- i k))))))
- (set! ((d 2) i) (+ d2
- (* (ac k n)
- (- (ref p 2 (+ i k))
- (ref p 2 (- i k)))))))))
+ (let ((d0 (d 0 i))
+ (d1 (d 1 i))
+ (d2 (d 2 i)))
+ (set! (d 0 i) (+ d0 (* (ac k n)
+ (- (ref p 0 (+ i k))
+ (ref p 0 (- i k))))))
+ (set! (d 1 i) (+ d1 (* (ac k n)
+ (- (ref p 1 (+ i k))
+ (ref p 1 (- i k))))))
+ (set! (d 2 i) (+ d2 (* (ac k n)
+ (- (ref p 2 (+ i k))
+ (ref p 2 (- i k)))))))))
(list n p d)))))
;;; Calculate bezier control points for the given open path
@@ -1260,18 +1246,18 @@
(do ((i 0 (+ i 1)))
((= i n))
- (set! xc (cons (list ((p 0) i)
- (+ ((p 0) i) (* ((d 0) i) (car (cs i))))
- (- ((p 0) (+ i 1)) (* ((d 0) (+ i 1)) (cadr (cs i))))
- ((p 0) (+ i 1))) xc))
- (set! yc (cons (list ((p 1) i)
- (+ ((p 1) i) (* ((d 1) i) (car (cs i))))
- (- ((p 1) (+ i 1)) (* ((d 1) (+ i 1)) (cadr (cs i))))
- ((p 1) (+ i 1))) yc))
- (set! zc (cons (list ((p 2) i)
- (+ ((p 2) i) (* ((d 2) i) (car (cs i))))
- (- ((p 2) (+ i 1)) (* ((d 2) (+ i 1)) (cadr (cs i))))
- ((p 2) (+ i 1))) zc)))
+ (set! xc (cons (list (p 0 i)
+ (+ (p 0 i) (* (d 0 i) (car (cs i))))
+ (- (p 0 (+ i 1)) (* (d 0 (+ i 1)) (cadr (cs i))))
+ (p 0 (+ i 1))) xc))
+ (set! yc (cons (list (p 1 i)
+ (+ (p 1 i) (* (d 1 i) (car (cs i))))
+ (- (p 1 (+ i 1)) (* (d 1 (+ i 1)) (cadr (cs i))))
+ (p 1 (+ i 1))) yc))
+ (set! zc (cons (list (p 2 i)
+ (+ (p 2 i) (* (d 2 i) (car (cs i))))
+ (- (p 2 (+ i 1)) (* (d 2 (+ i 1)) (cadr (cs i))))
+ (p 2 (+ i 1))) zc)))
(set! (bezier-bx path) (reverse xc))
(set! (bezier-by path) (reverse yc))
(set! (bezier-bz path) (reverse zc))))))
@@ -1310,30 +1296,30 @@
(zc ()))
(do ((i 0 (+ i 1)))
((= i n))
- (set! xc (cons (list ((p 0) i)
- (+ ((p 0) i) ((d 0) i))
- (- ((p 0) (+ i 1)) ((d 0) (+ i 1)))
- ((p 0) (+ i 1))) xc))
- (set! yc (cons (list ((p 1) i)
- (+ ((p 1) i) ((d 1) i))
- (- ((p 1) (+ i 1)) ((d 1) (+ i 1)))
- ((p 1) (+ i 1))) yc))
- (set! zc (cons (list ((p 2) i)
- (+ ((p 2) i) ((d 2) i))
- (- ((p 2) (+ i 1)) ((d 2) (+ i 1)))
- ((p 2) (+ i 1))) zc)))
- (set! (bezier-bx path) (append (reverse xc) (list (list ((p 0) n)
- (+ ((p 0) n) ((d 0) n))
- (- ((p 0) 0) ((d 0) 0))
- ((p 0) 0)))))
- (set! (bezier-by path) (append (reverse yc) (list (list ((p 1) n)
- (+ ((p 1) n) ((d 1) n))
- (- ((p 1) 0) ((d 1) 0))
- ((p 1) 0)))))
- (set! (bezier-bz path) (append (reverse zc) (list (list ((p 2) n)
- (+ ((p 2) n) ((d 2) n))
- (- ((p 2) 0) ((d 2) 0))
- ((p 2) 0)))))))
+ (set! xc (cons (list (p 0 i)
+ (+ (p 0 i) (d 0 i))
+ (- (p 0 (+ i 1)) (d 0 (+ i 1)))
+ (p 0 (+ i 1))) xc))
+ (set! yc (cons (list (p 1 i)
+ (+ (p 1 i) (d 1 i))
+ (- (p 1 (+ i 1)) (d 1 (+ i 1)))
+ (p 1 (+ i 1))) yc))
+ (set! zc (cons (list (p 2 i)
+ (+ (p 2 i) (d 2 i))
+ (- (p 2 (+ i 1)) (d 2 (+ i 1)))
+ (p 2 (+ i 1))) zc)))
+ (set! (bezier-bx path) (append (reverse xc) (list (list (p 0 n)
+ (+ (p 0 n) (d 0 n))
+ (- (p 0 0) (d 0 0))
+ (p 0 0)))))
+ (set! (bezier-by path) (append (reverse yc) (list (list (p 1 n)
+ (+ (p 1 n) (d 1 n))
+ (- (p 1 0) (d 1 0))
+ (p 1 0)))))
+ (set! (bezier-bz path) (append (reverse zc) (list (list (p 2 n)
+ (+ (p 2 n) (d 2 n))
+ (- (p 2 0) (d 2 0))
+ (p 2 0)))))))
;; not enough points to fit a closed path
(let ((xc ())
@@ -1422,19 +1408,19 @@
(cr (vector (make-vector 3 0.0) (make-vector 3 0.0) (make-vector 3 0.0))))
(do ((j 0 (+ j 1)))
((= j 3))
- (set! ((cr 0) j) (+ (* u1 ((c 0) j)) (* u ((c 0) (+ j 1)))))
- (set! ((cr 1) j) (+ (* u1 ((c 1) j)) (* u ((c 1) (+ j 1)))))
- (set! ((cr 2) j) (+ (* u1 ((c 2) j)) (* u ((c 2) (+ j 1))))))
+ (set! (cr 0 j) (+ (* u1 (c 0 j)) (* u (c 0 (+ j 1)))))
+ (set! (cr 1 j) (+ (* u1 (c 1 j)) (* u (c 1 (+ j 1)))))
+ (set! (cr 2 j) (+ (* u1 (c 2 j)) (* u (c 2 (+ j 1))))))
(do ((i 1 (- i 1)))
((< i 0))
(do ((j 0 (+ j 1)))
((> j i))
- (set! ((cr 0) j) (+ (* u1 ((cr 0) j)) (* u ((cr 0) (+ j 1)))))
- (set! ((cr 1) j) (+ (* u1 ((cr 1) j)) (* u ((cr 1) (+ j 1)))))
- (set! ((cr 2) j) (+ (* u1 ((cr 2) j)) (* u ((cr 2) (+ j 1)))))))
- (list ((cr 0) 0)
- ((cr 1) 0)
- ((cr 2) 0))))
+ (set! (cr 0 j) (+ (* u1 (cr 0 j)) (* u (cr 0 (+ j 1)))))
+ (set! (cr 1 j) (+ (* u1 (cr 1 j)) (* u (cr 1 (+ j 1)))))
+ (set! (cr 2 j) (+ (* u1 (cr 2 j)) (* u (cr 2 (+ j 1)))))))
+ (list (cr 0 0)
+ (cr 1 0)
+ (cr 2 0))))
(let* ((vals (bezier-point u c))
(x (car vals))
@@ -1454,9 +1440,9 @@
(xj (car val3))
(yj (cadr val3))
(zj (caddr val3)))
- (list (append xi (list x) xj)
- (append yi (list y) yj)
- (append zi (list z) zj))))))
+ (list (append xi (cons x xj))
+ (append yi (cons y yj))
+ (append zi (cons z zj)))))))
;; Create linear segment approximations of the bezier segments
;; make sure there are initial and final velocity values
@@ -1502,12 +1488,12 @@
(zs (caddr vals)))
;; approximate the bezier curve with linear segments
- (set! xrx (append xrx (list xi-bz) xs))
- (set! xry (append xry (list yi-bz) ys))
- (set! xrz (append xrz (list zi-bz) zs))
+ (set! xrx (append xrx (cons xi-bz xs)))
+ (set! xry (append xry (cons yi-bz ys)))
+ (set! xrz (append xrz (cons zi-bz zs)))
;; accumulate intermediate unknown velocities as nils
- (set! xrv (append xrv (list vi-bz) (make-list (length xs) #f)))
+ (set! xrv (append xrv (cons vi-bz (make-list (length xs) #f))))
(if (= i (- len 1))
(begin
;; add the last point
@@ -1559,10 +1545,10 @@
(if (= vi 0.0) (set! vi 1))
(for-each
(lambda (d)
- (set! tseg (cons (+ ti (if (= v vi)
- (/ d vi)
- (/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))
- tseg)))
+ (let ((seg (+ ti (if (= v vi)
+ (/ d vi)
+ (/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))))
+ (set! tseg (cons seg tseg))))
dseg))
(set! ti (car tseg))
(set! tseg (reverse tseg))
@@ -1600,7 +1586,7 @@
(let ((points (literal-points path))
(3d (literal-3d path))
(polar (literal-polar path)))
- (let ((vals (if polar (parse-polar-coordinates points 3d) (parse-cartesian-coordinates points 3d))))
+ (let ((vals ((if polar parse-polar-coordinates parse-cartesian-coordinates) points 3d)))
(set! (path-rx path) (car vals))
(set! (path-ry path) (cadr vals))
(set! (path-rz path) (caddr vals))
@@ -1660,10 +1646,10 @@
(let ((a (/ (* (- v vi) (+ v vi)) df 4)))
(for-each
(lambda (d)
- (set! tseg (cons (+ ti (if (= v vi)
- (/ d vi)
- (/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))
- tseg)))
+ (let ((seg (+ ti (if (= v vi)
+ (/ d vi)
+ (/ (- (sqrt (+ (* vi vi) (* 4 a d))) vi) (* 2 a))))))
+ (set! tseg (cons seg tseg))))
dseg))
(set! ti (car tseg))
(set! tseg (reverse tseg))
@@ -1686,22 +1672,21 @@
(define (spiral-render path)
;; Render a spiral path from the object data
- (let* ((start (* (/ (spiral-start-angle path) dlocsig-one-turn) 2 pi))
+ (let* ((start (/ (* (spiral-start-angle path) 2 pi) dlocsig-one-turn))
(total (if (spiral-total-angle path)
- (* (/ (spiral-total-angle path) dlocsig-one-turn) 2 pi)
+ (/ (* (spiral-total-angle path) 2 pi) dlocsig-one-turn)
(if (spiral-turns path)
(* (spiral-turns path) 2 pi)
(error 'mus-error "a spiral-path needs either a total-angle or turns, none specified~%"))))
- (steps (abs (/ total (* (/ (spiral-step-angle path) dlocsig-one-turn) 2 pi))))
+ (steps (abs (/ (* total dlocsig-one-turn) (* (spiral-step-angle path) 2 pi))))
(step (/ total (ceiling steps)
(if (< (spiral-step-angle path) 0) -1 1)))
(xdistance (x-norm (spiral-distance path) total))
(height (x-norm (spiral-height path) total)))
- (let* ((x ())
- (y ())
- (z ())
- (segments (round (abs (/ total step))))
- (len (+ 1 segments)))
+ (let ((x ())
+ (y ())
+ (z ())
+ (len (+ 1 (round (abs (/ total step))))))
(do ((i 0 (+ i 1))
(angle start (+ angle step)))
((>= i len))
@@ -1758,10 +1743,11 @@
(define (render-path path)
- (case (car path)
- ((bezier-path open-bezier-path) (bezier-render path))
- ((literal-path) (literal-render path))
- (else (spiral-render path))))
+ ((case (car path)
+ ((bezier-path open-bezier-path) bezier-render)
+ ((literal-path) literal-render)
+ (else spiral-render))
+ path))
@@ -1806,23 +1792,23 @@
((= row 3))
(do ((col 0 (+ 1 col)))
((= col 3))
- (set! ((AA row) col) 0.0)
+ (set! (AA row col) 0.0)
(do ((mid 0 (+ 1 mid)))
((= mid 3))
- (set! ((AA row) col)
- (+ ((AA row) col)
- (* ((A row) mid)
- ((A mid) col)))))))
+ (set! (AA row col)
+ (+ (AA row col)
+ (* (A row mid)
+ (A mid col)))))))
;; rotation matrix is I+sin(angle)*A+[1-cos(angle)]*A*A
(do ((row 0 (+ 1 row)))
((= row 3))
(do ((col 0 (+ 1 col)))
((= col 3))
- (set! ((rotate row) col)
- (+ ((I row) col)
- (* sn ((A row) col))
- (* omcs ((AA row) col))))))
+ (set! (rotate row col)
+ (+ (I row col)
+ (* sn (A row col))
+ (* omcs (AA row col))))))
rotate))
@@ -1830,7 +1816,8 @@
(render-path path))
(if (or scaling translation rotation)
;; there's at least one transformation to execute
- (let* ((rotation (and rotation (* 2 pi (/ rotation dlocsig-one-turn))))
+ (let* ((rotation (and (number? rotation)
+ (/ (* 2 pi rotation) dlocsig-one-turn)))
(matrix (and rotation (rotation-matrix (car rotation-axis)
(cadr rotation-axis)
(third rotation-axis)
@@ -1865,15 +1852,15 @@
(set! yw (- yw (cadr rotation-center)))
(set! zw (- zw (third rotation-center))))
;; rotation
- (let ((xr (+ (* ((matrix 0) 0) xw)
- (* ((matrix 1) 0) yw)
- (* ((matrix 2) 0) zw)))
- (yr (+ (* ((matrix 0) 1) xw)
- (* ((matrix 1) 1) yw)
- (* ((matrix 2) 1) zw)))
- (zr (+ (* ((matrix 0) 2) xw)
- (* ((matrix 1) 2) yw)
- (* ((matrix 2) 2) zw))))
+ (let ((xr (+ (* (matrix 0 0) xw)
+ (* (matrix 1 0) yw)
+ (* (matrix 2 0) zw)))
+ (yr (+ (* (matrix 0 1) xw)
+ (* (matrix 1 1) yw)
+ (* (matrix 2 1) zw)))
+ (zr (+ (* (matrix 0 2) xw)
+ (* (matrix 1 2) yw)
+ (* (matrix 2 2) zw))))
(set! xw xr)
(set! yw yr)
(set! zw zr))
@@ -1979,9 +1966,7 @@
(set! sum (+ sum (distance (- x2 x1) (- y2 y1) (- z2 z1))))))
sum))
(start-time (car tcoords))
- (end-time (tcoords (- (length tcoords) 1)))
- (total-time (- end-time start-time))
- (velocity (/ total-distance total-time))
+ (velocity (/ total-distance (- (tcoords (- (length tcoords) 1)) start-time)))
(now ()))
(do ((dist 0.0)
(len (length xcoords))
@@ -2262,9 +2247,7 @@
(Bx (- xa xb))
(Ay (cadr vert))
(By (- ya yb))
- (Cx (- xa))
- (Cy (- ya))
- (d (- (* By Cx) (* Bx Cy)))
+ (d (- (* By (- xa)) (* Bx (- ya))))
(f (- (* Ay Bx) (* Ax By))))
(and (not (= f 0))
(list (/ (* d Ax) f)
@@ -2312,11 +2295,11 @@
(rev-outputs (make-vector rev-channels 0.0))
;; attenuation with distance of reverberated signal
(ratt (if (>= dist inside-radius)
- (/ (expt dist reverb-power))
+ (expt dist (- reverb-power))
(- 1.0 (expt (/ dist inside-radius) (/ inside-reverb-power))))))
(let (;; attenuation with distance of direct signal
(att (if (>= dist inside-radius)
- (/ (expt dist direct-power))
+ (expt dist (- direct-power))
(- 1.0 (expt (/ dist inside-radius) (/ inside-direct-power))))))
(if (>= dist inside-radius)
;; outside the inner sphere, signal is sent to group
@@ -2635,6 +2618,7 @@
;; V
(set! (channel-gains v-offset) (cons time (channel-gains v-offset)))
(set! (channel-gains v-offset) (cons v (channel-gains v-offset))))
+
(when (>= ambisonics-v-order 3)
(set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1) att))
(set! no (* ambisonics-k2 z (if (zero? dist) 1 (/ dist)) att))
@@ -2653,100 +2637,120 @@
;; O
(set! (channel-gains o-offset) (cons time (channel-gains o-offset)))
(set! (channel-gains o-offset) (cons (* (if (zero? dist) 0 no) v) (channel-gains o-offset))))
+
(when (>= ambisonics-h-order 3)
;; P
(set! (channel-gains p-offset) (cons time (channel-gains p-offset)))
- (set! (channel-gains p-offset) (cons (* (if (zero? dist) 0 (/ att dist)) x
- (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
- (* 3 y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-gains p-offset)))
+ (set! (channel-gains p-offset) (let ((dist-p (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* 3 y y (if (zero? dist) 1 (/ 1.0 dist dist))))))
+ (cons (* (if (zero? dist) 0 (/ att dist)) x dist-p)
+ (channel-gains p-offset))))
;; Q
(set! (channel-gains q-offset) (cons time (channel-gains q-offset)))
- (set! (channel-gains q-offset) (cons (* (if (zero? dist) 0 (/ att dist)) y
- (- (* 3 x x (if (zero? dist) 1 (/ 1.0 dist dist)))
- (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-gains q-offset))))
+ (set! (channel-gains q-offset) (let ((dist-q (- (* 3 x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))))
+ (cons (* (if (zero? dist) 0 (/ att dist)) y dist-q)
+ (channel-gains q-offset)))))
;; push reverb gain into envelope
(when (= rev-channels 1)
;; mono reverb output
(set! (channel-rev-gains 0) (cons time (channel-rev-gains 0)))
(set! (channel-rev-gains 0) (cons (if (>= dist inside-radius)
- (/ (expt dist reverb-power))
+ (expt dist (- reverb-power))
(- 1.0 (expt (/ dist inside-radius) (/ inside-reverb-power))))
(channel-rev-gains 0))))
(when (> rev-channels 1)
- (let ((ho-ratt dlocsig-ambisonics-ho-rev-scaler))
- ;; multichannel reverb, send ambisonics components
- ;; W: 0.707
- (set! (channel-rev-gains w-offset) (cons time (channel-rev-gains w-offset)))
- (set! (channel-rev-gains w-offset) (cons rattW (channel-rev-gains w-offset)))
- ;; X: (* (cos A)(cos E))
- (set! (channel-rev-gains x-offset) (cons time (channel-rev-gains x-offset)))
- (set! (channel-rev-gains x-offset) (cons (* (if (zero? dist) 0 1) y (if (zero? dist) 1 (/ dist)) ratt)(channel-rev-gains x-offset)))
- ;; Y: (* (sin A)(cos E))
- (set! (channel-rev-gains y-offset) (cons time (channel-rev-gains y-offset)))
- (set! (channel-rev-gains y-offset) (cons (* (if (zero? dist) 0 1) (- x) (if (zero? dist) 1 (/ dist)) ratt)
- (channel-rev-gains y-offset)))
- (when (>= ambisonics-v-order 1)
- ;; Z: (sin E)
- (set! (channel-rev-gains z-offset) (cons time (channel-rev-gains z-offset)))
- (set! (channel-rev-gains z-offset) (cons (* (if (zero? dist) 0 1) z (if (zero? dist) 1 (/ dist)) ratt)
- (channel-rev-gains z-offset))))
- (when (>= ambisonics-v-order 2)
- ;; R
- (set! (channel-rev-gains r-offset) (cons time (channel-rev-gains r-offset)))
- (set! (channel-rev-gains r-offset) (cons (* (if (zero? dist) 0 (- (* 1.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 0.5)) ho-ratt ratt)
- (channel-rev-gains r-offset)))
- ;; S
- (set! (channel-rev-gains s-offset) (cons time (channel-rev-gains s-offset)))
- (set! (channel-rev-gains s-offset) (cons (* (if (zero? dist) 0 2) z (- x) (if (zero? dist) 1 (/ 1.0 dist dist)) ho-ratt ratt)
- (channel-rev-gains s-offset)))
- ;; T
- (set! (channel-rev-gains t-offset) (cons time (channel-rev-gains t-offset)))
- (set! (channel-rev-gains t-offset) (cons (* (if (zero? dist) 0 2) z y (if (zero? dist) 1 (/ 1.0 dist dist)) ho-ratt ratt)
- (channel-rev-gains t-offset))))
- (when (>= ambisonics-h-order 2)
- ;; U
- (set! (channel-rev-gains u-offset) (cons time (channel-rev-gains u-offset)))
- (set! (channel-rev-gains u-offset) (cons (* (if (zero? dist) 0 (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
- (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))) ho-ratt ratt)
- (channel-rev-gains u-offset)))
- ;; V
- (set! (channel-rev-gains v-offset) (cons time (channel-rev-gains v-offset)))
- (set! (channel-rev-gains v-offset) (cons (* (if (zero? dist) 0 2) (- x) y (if (zero? dist) 1 (/ 1.0 dist dist)) ho-ratt ratt)
- (channel-rev-gains v-offset))))
-
- (when (>= ambisonics-v-order 3)
- (set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1) ho-ratt ratt))
- (set! no (* ambisonics-k2 z (if (zero? dist) 1 (/ dist)) ratt))
- ;; K
- (set! (channel-rev-gains k-offset) (cons time (channel-rev-gains k-offset)))
- (set! (channel-rev-gains k-offset) (cons (* (if (zero? dist) 0 1)
- (- (* 2.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1.5)
- ho-ratt ratt)
- (channel-rev-gains k-offset)))
- ;; L
- (set! (channel-rev-gains l-offset) (cons time (channel-rev-gains l-offset)))
- (set! (channel-rev-gains l-offset) (cons (* (if (zero? dist) 0 (/ x dist)) lm) (channel-rev-gains l-offset)))
- ;; M
- (set! (channel-rev-gains m-offset) (cons time (channel-rev-gains m-offset)))
- (set! (channel-rev-gains m-offset) (cons (* (if (zero? dist) 0 (/ y dist)) lm) (channel-rev-gains m-offset)))
- ;; N
- (set! (channel-rev-gains n-offset) (cons time (channel-rev-gains n-offset)))
- (set! (channel-rev-gains n-offset) (cons (* (if (zero? dist) 0 no) u) (channel-rev-gains n-offset)))
- ;; O
- (set! (channel-rev-gains o-offset) (cons time (channel-rev-gains o-offset)))
- (set! (channel-rev-gains o-offset) (cons (* (if (zero? dist) 0 no) v) (channel-rev-gains o-offset))))
- (when (>= ambisonics-h-order 3)
- ;; P
- (set! (channel-rev-gains p-offset) (cons time (channel-rev-gains p-offset)))
- (set! (channel-rev-gains p-offset) (cons (* (if (zero? dist) 0 (/ ratt dist)) ho-ratt x
- (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
- (* 3 y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-rev-gains p-offset)))
- ;; Q
- (set! (channel-rev-gains q-offset) (cons time (channel-rev-gains q-offset)))
- (set! (channel-rev-gains q-offset) (cons (* (if (zero? dist) 0 (/ ratt dist)) ho-ratt y
- (- (* 3 x x (if (zero? dist) 1 (/ 1.0 dist dist)))
- (* y y (if (zero? dist) 1 (/ 1.0 dist dist))))) (channel-rev-gains q-offset))))
- ))))))
+ ;; multichannel reverb, send ambisonics components
+ ;; W: 0.707
+ (set! (channel-rev-gains w-offset) (cons time (channel-rev-gains w-offset)))
+ (set! (channel-rev-gains w-offset) (cons rattW (channel-rev-gains w-offset)))
+ ;; X: (* (cos A)(cos E))
+ (set! (channel-rev-gains x-offset) (cons time (channel-rev-gains x-offset)))
+ (set! (channel-rev-gains x-offset) (cons (* (if (zero? dist) 0 1) y (if (zero? dist) 1 (/ dist)) ratt)
+ (channel-rev-gains x-offset)))
+ ;; Y: (* (sin A)(cos E))
+ (set! (channel-rev-gains y-offset) (cons time (channel-rev-gains y-offset)))
+ (set! (channel-rev-gains y-offset) (cons (* (if (zero? dist) 0 1) (- x) (if (zero? dist) 1 (/ dist)) ratt)
+ (channel-rev-gains y-offset)))
+ (when (>= ambisonics-v-order 1)
+ ;; Z: (sin E)
+ (set! (channel-rev-gains z-offset) (cons time (channel-rev-gains z-offset)))
+ (set! (channel-rev-gains z-offset) (cons (* (if (zero? dist) 0 1) z (if (zero? dist) 1 (/ dist)) ratt)
+ (channel-rev-gains z-offset))))
+ (when (>= ambisonics-v-order 2)
+ ;; R
+ (set! (channel-rev-gains r-offset) (cons time (channel-rev-gains r-offset)))
+ (set! (channel-rev-gains r-offset) (cons (* (if (zero? dist) 0 (- (* 1.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 0.5))
+ dlocsig-ambisonics-ho-rev-scaler ratt)
+ (channel-rev-gains r-offset)))
+ ;; S
+ (set! (channel-rev-gains s-offset) (cons time (channel-rev-gains s-offset)))
+ (set! (channel-rev-gains s-offset) (cons (* (if (zero? dist) 0 2) z (- x) (if (zero? dist) 1 (/ 1.0 dist dist))
+ dlocsig-ambisonics-ho-rev-scaler ratt)
+ (channel-rev-gains s-offset)))
+ ;; T
+ (set! (channel-rev-gains t-offset) (cons time (channel-rev-gains t-offset)))
+ (set! (channel-rev-gains t-offset) (cons (* (if (zero? dist) 0 2) z y (if (zero? dist) 1 (/ 1.0 dist dist))
+ dlocsig-ambisonics-ho-rev-scaler ratt)
+ (channel-rev-gains t-offset))))
+ (when (>= ambisonics-h-order 2)
+ ;; U
+ (set! (channel-rev-gains u-offset) (cons time (channel-rev-gains u-offset)))
+ (set! (channel-rev-gains u-offset) (let ((dist-u (* (if (zero? dist) 0
+ (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist)))))
+ dlocsig-ambisonics-ho-rev-scaler ratt)))
+ (cons dist-u (channel-rev-gains u-offset))))
+ ;; V
+ (set! (channel-rev-gains v-offset) (cons time (channel-rev-gains v-offset)))
+ (set! (channel-rev-gains v-offset) (let ((dist-v (* (if (zero? dist) 0 2)
+ (- x) y
+ (if (zero? dist) 1 (/ 1.0 dist dist))
+ dlocsig-ambisonics-ho-rev-scaler ratt)))
+ (cons dist-v (channel-rev-gains v-offset)))))
+
+ (when (>= ambisonics-v-order 3)
+ (set! lm (* ambisonics-k1 (- (* 5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1)
+ dlocsig-ambisonics-ho-rev-scaler ratt))
+ (set! no (* ambisonics-k2 z (if (zero? dist) 1 (/ dist)) ratt))
+ ;; K
+ (set! (channel-rev-gains k-offset) (cons time (channel-rev-gains k-offset)))
+ (set! (channel-rev-gains k-offset) (cons (* (if (zero? dist) 0 1)
+ (- (* 2.5 z z (if (zero? dist) 1 (/ 1.0 dist dist))) 1.5)
+ dlocsig-ambisonics-ho-rev-scaler ratt)
+ (channel-rev-gains k-offset)))
+ ;; L
+ (set! (channel-rev-gains l-offset) (cons time (channel-rev-gains l-offset)))
+ (set! (channel-rev-gains l-offset) (cons (* (if (zero? dist) 0 (/ x dist)) lm)
+ (channel-rev-gains l-offset)))
+ ;; M
+ (set! (channel-rev-gains m-offset) (cons time (channel-rev-gains m-offset)))
+ (set! (channel-rev-gains m-offset) (cons (* (if (zero? dist) 0 (/ y dist)) lm)
+ (channel-rev-gains m-offset)))
+ ;; N
+ (set! (channel-rev-gains n-offset) (cons time (channel-rev-gains n-offset)))
+ (set! (channel-rev-gains n-offset) (cons (* (if (zero? dist) 0 no) u)
+ (channel-rev-gains n-offset)))
+ ;; O
+ (set! (channel-rev-gains o-offset) (cons time (channel-rev-gains o-offset)))
+ (set! (channel-rev-gains o-offset) (cons (* (if (zero? dist) 0 no) v)
+ (channel-rev-gains o-offset))))
+ (when (>= ambisonics-h-order 3)
+ ;; P
+ (set! (channel-rev-gains p-offset) (cons time (channel-rev-gains p-offset)))
+ (set! (channel-rev-gains p-offset) (cons (* (if (zero? dist) 0 (/ ratt dist))
+ dlocsig-ambisonics-ho-rev-scaler x
+ (- (* x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* 3 y y (if (zero? dist) 1 (/ 1.0 dist dist)))))
+ (channel-rev-gains p-offset)))
+ ;; Q
+ (set! (channel-rev-gains q-offset) (cons time (channel-rev-gains q-offset)))
+ (set! (channel-rev-gains q-offset) (cons (* (if (zero? dist) 0 (/ ratt dist))
+ dlocsig-ambisonics-ho-rev-scaler y
+ (- (* 3 x x (if (zero? dist) 1 (/ 1.0 dist dist)))
+ (* y y (if (zero? dist) 1 (/ 1.0 dist dist)))))
+ (channel-rev-gains q-offset))))
+ )))))
;; Render a trajectory breakpoint to a room for decoded ambisonics
;;
@@ -2796,7 +2800,7 @@
;; mono reverberation
(set! (channel-rev-gains 0) (cons time (channel-rev-gains 0)))
(set! (channel-rev-gains 0) (cons (if (>= dist inside-radius)
- (/ (expt dist reverb-power))
+ (expt dist (- reverb-power))
(- 1.0 (expt (/ dist inside-radius) (/ inside-reverb-power))))
(channel-rev-gains 0))))
;; multichannel reverb
@@ -2825,9 +2829,9 @@
(set! first-dist dist))
(set! last-dist dist)
;; remember maximum and minimum distances
- (if (or (not min-dist) (< dist min-dist))
+ (if (or (not (real? min-dist)) (< dist min-dist))
(set! min-dist dist))
- (if (or (not max-dist) (> dist max-dist))
+ (if (or (not (real? max-dist)) (> dist max-dist))
(set! max-dist dist))
;; push delay for current point (for doppler)
(if (or (null? dly)
@@ -2961,9 +2965,7 @@
;; (from Bill's dsp.scm)
(define (src-duration e)
(let* ((len (length e))
- (ex0 (car e))
- (ex1 (e (- len 2)))
- (all-x (- ex1 ex0))
+ (all-x (- (e (- len 2)) (e 0))) ; last x - first x
(dur 0.0))
(do ((i 0 (+ i 2)))
((>= i (- len 2)) dur)
diff --git a/draw.scm b/draw.scm
index b235935..3d500c7 100644
--- a/draw.scm
+++ b/draw.scm
@@ -135,10 +135,8 @@ whenever they're in the current view."))
(high-data (cadr data))
(size (length low-data))
(samps (- right left))
- (left-offset (max 0 (- beg left)))
- (left-bin (floor (/ (* size left-offset) samps)))
- (right-offset (- (min end right) left))
- (right-bin (floor (/ (* size right-offset) samps)))
+ (left-bin (floor (/ (* size (max 0 (- beg left))) samps)))
+ (right-bin (floor (/ (* size (- (min end right) left)) samps)))
(new-low-data (float-vector-subseq low-data left-bin right-bin))
(new-high-data (float-vector-subseq high-data left-bin right-bin)))
(set! (foreground-color snd chn) color)
diff --git a/dsp.scm b/dsp.scm
index 3009c85..30d399c 100644
--- a/dsp.scm
+++ b/dsp.scm
@@ -38,9 +38,7 @@
(let ((documentation "(src-duration envelope) returns the new duration of a sound after using 'envelope' for time-varying sampling-rate conversion"))
(lambda (e)
(let* ((len (length e))
- (ex0 (e 0))
- (ex1 (e (- len 2)))
- (all-x (- ex1 ex0))
+ (all-x (- (e (- len 2)) (e 0))) ; last x - first x
(dur 0.0))
(do ((i 0 (+ i 2)))
((>= i (- len 2)) dur)
@@ -137,8 +135,7 @@
;; the power-of-2 limitation is based on the underlying fft function's insistence on power-of-2 data sizes
;; see stretch-sound-via-dft below for a general version
(let* ((len (framples snd chn))
- (pow2 (ceiling (log len 2)))
- (fftlen (floor (expt 2 pow2)))
+ (fftlen (floor (expt 2 (ceiling (log len 2)))))
(fftlen2 (/ fftlen 2))
(fft-1 (- (* n fftlen) 1))
(fftscale (/ 1.0 fftlen))
@@ -176,7 +173,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
;; DFT + split
(if (< i n2)
(set! (fr i) (edot-product (* freq 0.0-1.0i i) in-data))
- (set! (fr (+ i (- out-n n 1))) (edot-product (* freq 0.0-1.0i i) in-data))))
+ (set! (fr (- (+ i out-n) n 1)) (edot-product (* freq 0.0-1.0i i) in-data))))
(set! freq (/ (* 2 pi) out-n))
(do ((i 0 (+ i 1)))
((= i out-n))
@@ -228,7 +225,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(s1 (- size 1)))
(float-vector-scale! x2 (/ -1.0 denom))
(copy x1 x0)
- (float-vector-scale! x0 (/ (+ 2.0 (- dm (* 2.0 km))) denom))
+ (float-vector-scale! x0 (/ (- (+ 2.0 dm) (* 2.0 km)) denom))
(float-vector-add! x0 x2)
(set! (x0 0) (+ (x0 0) (* p2 (+ (x1 s1) (x1 1)))))
(do ((i 1 (+ i 1)))
@@ -247,7 +244,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(km (/ (xsprings i) mass))
(cm (/ (esprings i) mass)))
(let ((denom (+ 1.0 dm cm)))
- (let ((p1 (/ (+ 2.0 (- dm (* 2.0 km))) denom))
+ (let ((p1 (/ (- (+ 2.0 dm) (* 2.0 km)) denom))
(p2 (/ km denom))
(p3 (/ -1.0 denom))
(p4 (/ (haptics i) (* mass denom)))
@@ -352,8 +349,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(define spot-freq
(let ((documentation "(spot-freq samp snd chn) tries to determine the current pitch: (spot-freq (left-sample))"))
(lambda* (s0 snd chn)
- (let* ((pow2 (ceiling (log (/ (srate snd) 20.0) 2)))
- (fftlen (floor (expt 2 pow2)))
+ (let* ((fftlen (floor (expt 2 (ceiling (log (/ (srate snd) 20.0) 2)))))
(data (autocorrelate (channel->float-vector s0 fftlen snd chn)))
(cor-peak (float-vector-peak data)))
(if (= cor-peak 0.0)
@@ -384,23 +380,22 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(define chorus
(let ((documentation "(chorus) tries to produce the chorus sound effect"))
(lambda ()
+ (let ((make-flanger
+ (let ((chorus-time .05)
+ (chorus-amount 20.0)
+ (chorus-speed 10.0))
+ (lambda ()
+ (let ((ri (make-rand-interp :frequency chorus-speed :amplitude chorus-amount))
+ (len (floor (random (* 3.0 chorus-time (srate))))))
+ (list (make-delay len :max-size (+ len chorus-amount 1)) ri)))))
+
+ (flanger (lambda (dly inval)
+ (+ inval
+ (delay (car dly)
+ inval
+ (rand-interp (cadr dly))))))
+ (dlys (make-vector chorus-size)))
- (define make-flanger
- (let ((chorus-time .05)
- (chorus-amount 20.0)
- (chorus-speed 10.0))
- (lambda ()
- (let ((ri (make-rand-interp :frequency chorus-speed :amplitude chorus-amount))
- (len (floor (random (* 3.0 chorus-time (srate))))))
- (list (make-delay len :max-size (+ len chorus-amount 1)) ri)))))
-
- (define (flanger dly inval)
- (+ inval
- (delay (car dly)
- inval
- (rand-interp (cadr dly)))))
-
- (let ((dlys (make-vector chorus-size)))
(do ((i 0 (+ i 1)))
((= i chorus-size))
(set! (dlys i) (make-flanger)))
@@ -436,8 +431,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((documentation "(zero-phase snd chn) calls fft, sets all phases to 0, and un-ffts"))
(lambda* (snd chn)
(let* ((len (framples snd chn))
- (pow2 (ceiling (log len 2)))
- (fftlen (floor (expt 2 pow2)))
+ (fftlen (floor (expt 2 (ceiling (log len 2)))))
(fftscale (/ 1.0 fftlen))
(rl (channel->float-vector 0 fftlen snd chn))
(old-pk (float-vector-peak rl))
@@ -456,8 +450,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(let ((documentation "(rotate-phase func snd chn) calls fft, applies func to each phase, then un-ffts"))
(lambda* (func snd chn)
(let* ((len (framples snd chn))
- (pow2 (ceiling (log len 2)))
- (fftlen (floor (expt 2 pow2)))
+ (fftlen (floor (expt 2 (ceiling (log len 2)))))
(fftlen2 (floor (/ fftlen 2)))
(fftscale (/ 1.0 fftlen))
(rl (channel->float-vector 0 fftlen snd chn))
@@ -536,21 +529,20 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
(define spectrum->coeffs
(let ((documentation "(spectrum->coeffs order spectr) returns FIR filter coefficients given the filter order and desired spectral envelope (a float-vector)"))
(lambda (order spectr)
- (let* ((coeffs (make-float-vector order))
- (n order)
- (m (floor (/ (+ n 1) 2)))
- (am (* 0.5 (+ n 1)))
- (q (/ (* pi 2.0) n)))
+ (let ((coeffs (make-float-vector order))
+ (m (floor (/ (+ order 1) 2)))
+ (am (* 0.5 (+ order 1)))
+ (q (/ (* pi 2.0) order)))
(if (not (float-vector? spectr))
(error "spectrum->coeffs spectrum argument should be a float-vector"))
(do ((j 0 (+ j 1))
- (jj (- n 1) (- jj 1)))
+ (jj (- order 1) (- jj 1)))
((= j m) coeffs)
(let ((xt (* 0.5 (spectr 0))))
(do ((i 1 (+ i 1)))
((= i m))
(set! xt (+ xt (* (spectr i) (cos (* q i (- am j 1)))))))
- (let ((coeff (* 2.0 (/ xt n))))
+ (let ((coeff (* 2.0 (/ xt order))))
(set! (coeffs j) coeff)
(set! (coeffs jj) coeff))))))))
@@ -823,7 +815,7 @@ squeezing in the frequency domain, then using the inverse DFT to get the time do
c1)
(float-vector 0.0
(* 2.0 (- r2 1.0) c1)
- (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1)))))))
+ (* (- (+ 1.0 r2) (* r (sqrt 2.0))) c1)))))))
(define make-butter-low-pass
(let ((documentation "(make-butter-low-pass freq) makes a Butterworth filter with low pass cutoff at 'freq'. The result \
@@ -836,7 +828,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(float-vector c1 (* 2.0 c1) c1)
(float-vector 0.0
(* 2.0 (- 1.0 r2) c1)
- (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1)))))))
+ (* (- (+ 1.0 r2) (* r (sqrt 2.0))) c1)))))))
(define make-butter-band-pass
(let ((documentation "(make-butter-band-pass freq band) makes a bandpass Butterworth filter with low edge at 'freq' and width 'band'"))
@@ -879,6 +871,9 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(float-vector a0 a1 a2)
(float-vector 0.0 b1 b2)))))
+(define (make-local-biquad a0 a1 a2 gamma beta)
+ (make-biquad a0 a1 a2 (* -2.0 gamma) (* 2.0 beta)))
+
(define* (make-iir-low-pass-2 fc din) ; din=(sqrt 2.0) for example (suggested range 0.2.. 10)
(let* ((theta (/ (* 2 pi fc) *clm-srate*))
(d (or din (sqrt 2.0)))
@@ -886,7 +881,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 (* (/ d 2) (sin theta))))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (* 0.5 (- (+ 0.5 beta) gamma))))
- (make-biquad alpha (* 2.0 alpha) alpha (* -2.0 gamma) (* 2.0 beta))))
+ (make-local-biquad alpha (* 2.0 alpha) alpha gamma beta)))
(define* (make-iir-high-pass-2 fc din)
(let* ((theta (/ (* 2 pi fc) *clm-srate*))
@@ -895,7 +890,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 (* (/ d 2) (sin theta))))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (* 0.5 (+ 0.5 beta gamma))))
- (make-biquad alpha (* -2.0 alpha) alpha (* -2.0 gamma) (* 2.0 beta))))
+ (make-local-biquad alpha (* -2.0 alpha) alpha gamma beta)))
(define (make-iir-band-pass-2 f1 f2)
(let* ((theta (/ (* 2 pi (sqrt (* f1 f2))) *clm-srate*))
@@ -905,7 +900,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 t2))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (- 0.5 beta)))
- (make-biquad alpha 0.0 (- alpha) (* -2.0 gamma) (* 2.0 beta))))
+ (make-local-biquad alpha 0.0 (- alpha) gamma beta)))
(define (make-iir-band-stop-2 f1 f2)
(let* ((theta (/ (* 2 pi (sqrt (* f1 f2))) *clm-srate*))
@@ -915,7 +910,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 t2))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (+ 0.5 beta)))
- (make-biquad alpha (* -2.0 gamma) alpha (* -2.0 gamma) (* 2.0 beta))))
+ (make-local-biquad alpha (* -2.0 gamma) alpha gamma beta)))
#|
(define* (old-make-eliminate-hum (hum-freq 60.0) (hum-harmonics 5) (bandwidth 10))
@@ -964,7 +959,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(+ 1.0 t2))))
(gamma (* (+ 0.5 beta) (cos theta)))
(alpha (- 0.5 beta))
- (flt (make-biquad alpha 0.0 (- alpha) (* -2.0 gamma) (* 2.0 beta)))
+ (flt (make-local-biquad alpha 0.0 (- alpha) gamma beta))
(m1 (- m 1.0)))
(lambda (x) (+ x (* m1 (filter flt x))))))
@@ -1102,7 +1097,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(betajk (* 0.5 (/ (- 1.0 (* 0.5 dk1 (sin thetajk)))
(+ 1.0 (* 0.5 dk1 (sin thetajk))))))
(gammajk (* (+ 0.5 betajk) (cos thetajk)))
- (alphajk (* 0.5 (+ 0.5 betajk) (/ (- 1.0 (cos thetajk)) (- 1.0 ct)))))
+ (alphajk (/ (* 0.5 (+ 0.5 betajk) (- 1.0 (cos thetajk))) (- 1.0 ct))))
(set! xcoeffs (cons (float-vector (* 2 alphajk) (* -4 ct alphajk) (* 2 alphajk)) xcoeffs))
(set! ycoeffs (cons (float-vector 1.0 (* -2.0 gammajk) (* 2.0 betajk)) ycoeffs))
(if (= j 1)
@@ -1191,7 +1186,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(lambda (f n z)
;; using vector to allow complex sums (z=e^2*pi*i/n -> fourier transform)
;; (z-transform data n (exp (complex 0.0 (* (/ 2.0 n) pi))))
- (let ((res (if (float-vector? f) (make-float-vector n) (make-vector n))))
+ (let ((res ((if (float-vector? f) make-float-vector make-vector) n)))
(do ((w 0 (+ 1 w)))
((= w n))
(let ((sum 0.0)
@@ -1249,8 +1244,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(define goertzel
(let ((documentation "(goertzel freq beg dur snd) returns the amplitude of the 'freq' spectral component"))
(lambda* (freq (beg 0) dur snd)
- (let* ((sr (srate snd))
- (rfreq (/ (* 2.0 pi freq) sr))
+ (let* ((rfreq (/ (* 2.0 pi freq) (srate snd)))
(cs (* 2.0 (cos rfreq))))
(let ((reader (make-sampler beg snd 0))
(len (- (if (number? dur) dur (- (framples snd 0) beg)) 2))
@@ -1281,7 +1275,7 @@ can be used directly: (filter-sound (make-butter-low-pass 500.0)), or via the 'b
(let ((documentation "(make-spencer-filter) is a version of make-fir-filter; it returns one of the standard smoothing filters from \
the era when computers were human beings"))
(lambda ()
- (make-fir-filter 15 (apply float-vector (map (lambda (n) (/ n 320.0)) (list -3 -6 -5 3 21 46 67 74 67 46 21 3 -5 -6 -3)))))))
+ (make-fir-filter 15 (apply float-vector (map (lambda (n) (/ n 320.0)) '(-3 -6 -5 3 21 46 67 74 67 46 21 3 -5 -6 -3)))))))
;;; -------- any-random
@@ -1294,9 +1288,8 @@ the era when computers were human beings"))
(if (not e)
(random amount)
(let next-random ()
- (let* ((len (length e))
- (x (random (* 1.0 (e (- len 2)))))
- (y (random 1.0)))
+ (let ((x (random (* 1.0 (e (- (length e) 2)))))
+ (y (random 1.0)))
(if (<= y (envelope-interp x e))
x
(next-random)))))))
@@ -1559,7 +1552,7 @@ shift the given channel in pitch without changing its length. The higher 'order
(let ((data (channel->float-vector beg dur snd chn edpos)))
(let ((len (length data))
(mx (float-vector-peak data)))
- (let ((summer (make-float-vector len 0.0)))
+ (let ((summer (make-float-vector len)))
(set! *output* summer)
(do ((i 0 (+ i 1)))
((= i pairs))
@@ -1597,7 +1590,7 @@ shift the given channel in pitch without changing its length. The higher 'order
(let ((data (channel->float-vector beg dur snd chn edpos)))
(let ((len (length data))
(mx (float-vector-peak data)))
- (let ((summer (make-float-vector len 0.0)))
+ (let ((summer (make-float-vector len)))
(set! *output* summer)
(do ((i 0 (+ i 1)))
((= i pairs))
@@ -1665,8 +1658,8 @@ shift the given channel in pitch without changing its length. The higher 'order
(fft-len (if (< num-coeffs 2)
len
(expt 2 (ceiling (log (* (- num-coeffs 1) len) 2)))))
- (rl1 (make-float-vector fft-len 0.0))
- (rl2 (make-float-vector fft-len 0.0))
+ (rl1 (make-float-vector fft-len))
+ (rl2 (make-float-vector fft-len))
(newv (make-float-vector fft-len)))
(if (> (coeffs 0) 0.0)
(let ((dither (coeffs 0)))
@@ -1961,8 +1954,7 @@ and replaces it with the spectrum given in coeffs"))
(let* ((snd (hook 'snd))
(chn (hook 'chn))
(ls (left-sample snd chn))
- (rs (right-sample snd chn))
- (fftlen (floor (expt 2 (ceiling (log (+ 1 (- rs ls)) 2))))))
+ (fftlen (floor (expt 2 (ceiling (log (- (+ (right-sample snd chn) 1) ls) 2))))))
(when (> fftlen 0)
(let ((data (channel->float-vector ls fftlen snd chn))
(normalized (not (= (transform-normalization snd chn) dont-normalize)))
@@ -1979,20 +1971,17 @@ and replaces it with the spectrum given in coeffs"))
;; bark settings
(bark-low (floor (bark 20.0)))
- (bark-high (ceiling (bark (* 0.5 sr))))
- (bark-frqscl (/ data-len (- bark-high bark-low)))
+ (bark-frqscl (/ data-len (- (ceiling (bark (* 0.5 sr))) bark-low)))
(bark-data (make-float-vector data-len))
;; mel settings
(mel-low (floor (mel 20.0)))
- (mel-high (ceiling (mel (* 0.5 sr))))
- (mel-frqscl (/ data-len (- mel-high mel-low)))
+ (mel-frqscl (/ data-len (- (ceiling (mel (* 0.5 sr))) mel-low)))
(mel-data (make-float-vector data-len))
;; erb settings
(erb-low (floor (erb 20.0)))
- (erb-high (ceiling (erb (* 0.5 sr))))
- (erb-frqscl (/ data-len (- erb-high erb-low)))
+ (erb-frqscl (/ data-len (- (ceiling (erb (* 0.5 sr))) erb-low)))
(erb-data (make-float-vector data-len)))
(set! bark-fft-size fftlen)
@@ -2049,72 +2038,69 @@ and replaces it with the spectrum given in coeffs"))
(minor-tick-len 6)
(major-tick-len 12)
(bark-label-font (snd-font 3))
- (label-pos (+ axis-x0 (* .45 (- axis-x1 axis-x0))))
- (cr (make-cairo (car (channel-widgets snd chn)))))
-
- (define scale-position
- (let ((sr2 (* 0.5 (srate snd))))
- (lambda (scale f)
- (let ((b20 (scale 20.0)))
- (round (+ axis-x0
- (/ (* (- axis-x1 axis-x0) (- (scale f) b20))
- (- (scale sr2) b20))))))))
-
- (define (bark-position f) (scale-position bark f))
- (define (mel-position f) (scale-position mel f))
- (define (erb-position f) (scale-position erb f))
-
- (define draw-bark-ticks
- (let ((tick-y0 axis-y1)
- (minor-y0 (+ axis-y1 minor-tick-len))
- (major-y0 (+ axis-y1 major-tick-len))
- (axis-y0 (axinfo 13))
- (bark-numbers-font (snd-font 2)))
-
- (lambda (bark-function)
- (if bark-numbers-font (set! (current-font snd chn copy-context) bark-numbers-font))
-
- (draw-line axis-x0 tick-y0 axis-x0 major-y0 snd chn copy-context cr)
- (let ((i1000 (scale-position bark-function 1000.0))
- (i10000 (scale-position bark-function 10000.0)))
-
- (draw-line i1000 tick-y0 i1000 major-y0 snd chn copy-context cr)
- (draw-line i10000 tick-y0 i10000 major-y0 snd chn copy-context cr)
-
- (draw-string "20" axis-x0 major-y0 snd chn copy-context cr)
- (draw-string "1000" (- i1000 12) major-y0 snd chn copy-context cr)
- (draw-string "10000" (- i10000 24) major-y0 snd chn copy-context cr)
-
- (draw-string (format #f "fft size: ~D" bark-fft-size) (+ axis-x0 10) axis-y0 snd chn copy-context cr)
-
- (do ((i 100 (+ i 100)))
- ((= i 1000))
- (let ((i100 (scale-position bark-function i)))
- (draw-line i100 tick-y0 i100 minor-y0 snd chn copy-context cr)))
-
- (do ((i 2000 (+ i 1000)))
- ((= i 10000))
- (let ((i1000 (scale-position bark-function i)))
- (draw-line i1000 tick-y0 i1000 minor-y0 snd chn copy-context cr)))))))
-
- ;; bark label/ticks
- (set! (foreground-color snd chn copy-context) color1)
- (if (= bark-tick-function 0) (draw-bark-ticks bark-position))
- (if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
- (draw-string "bark," label-pos (+ axis-y1 label-height) snd chn copy-context cr)
-
- ;; mel label/ticks
- (set! (foreground-color snd chn copy-context) color2)
- (if (= bark-tick-function 1) (draw-bark-ticks mel-position))
- (if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
- (draw-string "mel," (+ (* char-width 6) label-pos) (+ axis-y1 label-height) snd chn copy-context cr)
+ (label-pos (round (+ axis-x0 (* .45 (- axis-x1 axis-x0)))))
+ (cr (make-cairo (car (channel-widgets snd chn))))
+ (scale-position (let ((sr2 (* 0.5 (srate snd))))
+ (lambda (scale f)
+ (let ((b20 (scale 20.0)))
+ (round (+ axis-x0
+ (/ (* (- axis-x1 axis-x0) (- (scale f) b20))
+ (- (scale sr2) b20))))))))
+ (bark-position (lambda (f) (scale-position bark f)))
+ (mel-position (lambda (f) (scale-position mel f)))
+ (erb-position (lambda (f) (scale-position erb f))))
- ;; erb label/ticks
- (set! (foreground-color snd chn copy-context) color3)
- (if (= bark-tick-function 2) (draw-bark-ticks erb-position))
- (if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
- (draw-string "erb" (+ (* char-width 11) label-pos) (+ axis-y1 label-height) snd chn copy-context cr)
- (free-cairo cr))
+ (let ((draw-bark-ticks
+ (let ((tick-y0 axis-y1)
+ (minor-y0 (+ axis-y1 minor-tick-len))
+ (major-y0 (+ axis-y1 major-tick-len))
+ (axis-y0 (axinfo 13))
+ (bark-numbers-font (snd-font 2)))
+
+ (lambda (bark-function)
+ (if bark-numbers-font (set! (current-font snd chn copy-context) bark-numbers-font))
+
+ (draw-line axis-x0 tick-y0 axis-x0 major-y0 snd chn copy-context cr)
+ (let ((i1000 (scale-position bark-function 1000.0))
+ (i10000 (scale-position bark-function 10000.0)))
+
+ (draw-line i1000 tick-y0 i1000 major-y0 snd chn copy-context cr)
+ (draw-line i10000 tick-y0 i10000 major-y0 snd chn copy-context cr)
+
+ (draw-string "20" axis-x0 major-y0 snd chn copy-context cr)
+ (draw-string "1000" (- i1000 12) major-y0 snd chn copy-context cr)
+ (draw-string "10000" (- i10000 24) major-y0 snd chn copy-context cr)
+
+ (draw-string (format #f "fft size: ~D" bark-fft-size) (+ axis-x0 10) axis-y0 snd chn copy-context cr)
+
+ (do ((i 100 (+ i 100)))
+ ((= i 1000))
+ (let ((i100 (scale-position bark-function i)))
+ (draw-line i100 tick-y0 i100 minor-y0 snd chn copy-context cr)))
+
+ (do ((i 2000 (+ i 1000)))
+ ((= i 10000))
+ (let ((i1000 (scale-position bark-function i)))
+ (draw-line i1000 tick-y0 i1000 minor-y0 snd chn copy-context cr))))))))
+
+ ;; bark label/ticks
+ (set! (foreground-color snd chn copy-context) color1)
+ (if (= bark-tick-function 0) (draw-bark-ticks bark-position))
+ (if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
+ (draw-string "bark," label-pos (+ axis-y1 label-height) snd chn copy-context cr)
+
+ ;; mel label/ticks
+ (set! (foreground-color snd chn copy-context) color2)
+ (if (= bark-tick-function 1) (draw-bark-ticks mel-position))
+ (if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
+ (draw-string "mel," (+ (* char-width 6) label-pos) (+ axis-y1 label-height) snd chn copy-context cr)
+
+ ;; erb label/ticks
+ (set! (foreground-color snd chn copy-context) color3)
+ (if (= bark-tick-function 2) (draw-bark-ticks erb-position))
+ (if bark-label-font (set! (current-font snd chn copy-context) bark-label-font))
+ (draw-string "erb" (+ (* char-width 11) label-pos) (+ axis-y1 label-height) snd chn copy-context cr)
+ (free-cairo cr)))
(set! (foreground-color snd chn copy-context) old-foreground-color)))
@@ -2163,10 +2149,10 @@ and replaces it with the spectrum given in coeffs"))
(lambda (data n m)
;; translated and changed to use 0-based arrays from memcof of NRinC
- (let ((d (make-float-vector m 0.0))
- (wk1 (make-float-vector n 0.0))
- (wk2 (make-float-vector n 0.0))
- (wkm (make-float-vector n 0.0)))
+ (let ((d (make-float-vector m))
+ (wk1 (make-float-vector n))
+ (wk2 (make-float-vector n))
+ (wkm (make-float-vector n)))
(copy data wk1)
(do ((j 1 (+ j 1))
(k 0 (+ k 1)))
@@ -2204,8 +2190,8 @@ and replaces it with the spectrum given in coeffs"))
'n' data points of 'data' (a float-vector), and produces 'nf' new data points (in a float-vector) as its prediction. If 'clipped' is #t, the new data \
is assumed to be outside -1.0 to 1.0."))
(lambda* (data n coeffs m nf clipped)
- (let ((future (make-float-vector nf 0.0))
- (reg (make-float-vector m 0.0)))
+ (let ((future (make-float-vector nf))
+ (reg (make-float-vector m)))
(do ((i 0 (+ i 1))
(j (- n 1) (- j 1)))
((= i m))
@@ -2270,9 +2256,8 @@ is assumed to be outside -1.0 to 1.0."))
((>= clip clips))
(let* ((clip-beg (clip-data clip)) ; clip-beg to clip-end inclusive are clipped
(clip-end (clip-data (+ 1 clip)))
- (clip-len (+ 1 (- clip-end clip-beg)))
- (min-data-len 32)
- (data-len (max min-data-len (* clip-len 4))))
+ (clip-len (- (+ clip-end 1) clip-beg))
+ (data-len (max 32 (* clip-len 4))))
(set! max-len (max max-len clip-len))
@@ -2306,7 +2291,7 @@ is assumed to be outside -1.0 to 1.0."))
backward-predict-len
clip-len #f))
- (new-data (make-float-vector clip-len 0.0)))
+ (new-data (make-float-vector clip-len)))
(if (> clip-len 1)
(do ((i 0 (+ i 1))
@@ -2323,9 +2308,7 @@ is assumed to be outside -1.0 to 1.0."))
;; todo perhaps if multichannel and channels are correlated and one is not clipped -- use
;; its data to help reconstruct clipped case?
- (set! (new-data 0) (if (> (future 0) 0.0)
- (max (future 0) (past 0))
- (min (future 0) (past 0)))))
+ (set! (new-data 0) ((if (> (future 0) 0.0) max min) (future 0) (past 0))))
;; write reconstruction
(float-vector->channel new-data clip-beg clip-len snd chn))))))))
@@ -2426,8 +2409,8 @@ is assumed to be outside -1.0 to 1.0."))
(set! (pivots col) (+ (pivots col) 1))
;(format () "i: ~D, row: ~D, col: ~A~%" i row col)
(if (not (= row col))
- (let ((temp (if b (b row) 0.0)))
- (if b
+ (let ((temp (if (sequence? b) (b row) 0.0)))
+ (if (sequence? b)
(begin
(set! (b row) (b col))
(set! (b col) temp)))
@@ -2473,7 +2456,7 @@ is assumed to be outside -1.0 to 1.0."))
(if (even? size)
(set! size (+ size 1)))
(let ((n (/ (- size 1) 2))
- (a (make-float-vector (list (+ 1 order) (+ 1 order)) 0.0)))
+ (a (make-float-vector (list (+ 1 order) (+ 1 order)))))
(do ((i 0 (+ i 1)))
((> i (* order 2)))
(let ((sum (if (= i 0) 1.0 0.0)))
@@ -2488,10 +2471,10 @@ is assumed to be outside -1.0 to 1.0."))
(do ((k (- m) (+ k 2)))
((> k m))
(set! (a (/ (+ i k) 2) (/ (- i k) 2)) sum)))))
- (let ((b (matrix-solve a (let ((f (make-float-vector (+ order 1) 0.0)))
+ (let ((b (matrix-solve a (let ((f (make-float-vector (+ order 1))))
(set! (f 0) 1.0) ; set others instead for derivative
f)))
- (result (make-float-vector size 0.0)))
+ (result (make-float-vector size)))
(do ((k (- n) (+ k 1))
(i 0 (+ i 1)))
((> k n))
diff --git a/edit-menu.scm b/edit-menu.scm
index e4f5b27..43d8b8d 100644
--- a/edit-menu.scm
+++ b/edit-menu.scm
@@ -55,7 +55,7 @@
(display "Could not make new sound.")(newline))
(begin
(insert-sound ofile-name 0 0 nsnd 0)
- (insert-sound ofile-name 0 (if (> 0 (channels old-sound)) 1 0) nsnd 1)))))
+ (insert-sound ofile-name 0 (if (> (channels old-sound) 1) 1 0) nsnd 1)))))
(add-to-menu edit-menu "Make Stereofile" make-stereofile)
diff --git a/edit123.scm b/edit123.scm
index b80bc7a..c9a6497 100644
--- a/edit123.scm
+++ b/edit123.scm
@@ -136,8 +136,8 @@
(define (goto-named-mark name)
(select-channel 0)
- (if (find-mark name)
- (set! (cursor) (mark-sample (find-mark name))))
+ (set! (cursor) (cond ((find-mark name) => mark-sample)
+ (else (error 'no-such-mark "can't find mark named ~S" name))))
)
(define (delete-named-mark name)
@@ -215,32 +215,32 @@
(if (not (selection?)) (make-selection (cursor) (+ (cursor) 20000)))
(if (< (selection-framples) 2000) (make-selection (- (cursor) 2000) (cursor)))
; is cursor inside of selection ?
- (if (or (< (cursor) (selection-position)) (> (cursor) (+ (selection-position) (selection-framples))))
- (begin
- (make-selection (cursor) (+ (cursor) (selection-framples)))
- (stop-playing)
- (eos)))
- (if (and (>= (cursor) (selection-position)) (<= (cursor) (+ (selection-position) (selection-framples))))
- (begin
- (stop-playing)
- (eos)
- (make-selection (cursor) (+ (cursor) (selection-framples)))))
+ (if (not (<= (selection-position) (cursor) (+ (selection-position) (selection-framples))))
+ (begin
+ (make-selection (cursor) (+ (cursor) (selection-framples)))
+ (stop-playing)
+ (eos)))
+ (if (>= (+ (selection-position) (selection-framples)) (cursor) (selection-position))
+ (begin
+ (stop-playing)
+ (eos)
+ (make-selection (cursor) (+ (cursor) (selection-framples)))))
(play (selection)))
(define (backward-selection)
(if (not (selection?)) (make-selection (- (cursor) 20000) (cursor)))
(if (< (selection-framples) 2000) (make-selection (- (cursor) 2000) (cursor)))
- (if (or (< (cursor) (selection-position)) (> (cursor) (+ (selection-position) (selection-framples))))
- (begin
- (make-selection (cursor) (- (cursor) (selection-framples)))
- (stop-playing)
- (set! (cursor) (selection-position))))
+ (if (not (<= (selection-position) (cursor) (+ (selection-position) (selection-framples))))
+ (begin
+ (make-selection (cursor) (- (cursor) (selection-framples)))
+ (stop-playing)
+ (set! (cursor) (selection-position))))
- (if (and (>= (cursor) (selection-position)) (<= (cursor) (+ (selection-position) (selection-framples))))
- (begin
- (stop-playing)
- (set! (cursor) (selection-position))))
+ (if (>= (+ (selection-position) (selection-framples)) (cursor) (selection-position))
+ (begin
+ (stop-playing)
+ (set! (cursor) (selection-position))))
(make-selection (- (cursor) (selection-framples)) (cursor) )
(play (selection)))
@@ -248,8 +248,7 @@
(define (mark-start length)
(select-channel 0)
(if (find-mark "start")
- (delete-named-mark "start")
- )
+ (delete-named-mark "start"))
(mark-named "start")
(stop-playing)
(goto-named-mark "start")
diff --git a/effects-utils.scm b/effects-utils.scm
index 6a7b153..4d6618b 100644
--- a/effects-utils.scm
+++ b/effects-utils.scm
@@ -16,9 +16,7 @@
(define activate-dialog
(let ((documentation "(activate-dialog dialog) makes 'dialog' active and brings it to the top of the currently displayed widgets"))
(lambda (dialog)
- (if (not (XtIsManaged dialog))
- (XtManageChild dialog)
- (raise-dialog dialog)))))
+ ((if (not (XtIsManaged dialog)) XtManageChild raise-dialog) dialog))))
(define for-each-child
(let ((documentation "(for-each-child w func) applies 'func' to 'w' and to its descendents"))
diff --git a/env.scm b/env.scm
index 0c043f5..43f36a0 100644
--- a/env.scm
+++ b/env.scm
@@ -197,7 +197,7 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
(set! scl (if old-dec
(/ (- new-dec new-att) (- old-dec old-att))
(/ (- last-x new-att) (- last-x old-att)))))
- (when (and old-dec
+ (when (and (real? old-dec)
(< x0 old-dec)
(>= x1 old-dec))
(set! y0 (if (= x1 old-dec)
@@ -222,8 +222,7 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
(lambda* (e scl (offset 0))
(if (null? e)
()
- (append (list (car e) (+ offset (* scl (cadr e))))
- (scale-envelope (cddr e) scl offset))))))
+ (cons (car e) (cons (+ offset (* scl (cadr e))) (scale-envelope (cddr e) scl offset)))))))
;;; -------- reverse-envelope
@@ -255,7 +254,7 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
newe
(cat-1 (cddr e)
(cons (cadr e)
- (cons (+ (- (car e) x0) xoff)
+ (cons (- (+ (car e) xoff) x0)
newe))
xoff
x0)))
@@ -289,7 +288,7 @@ repetition to be in reverse."))
(rev-env (cddr (reverse ur-env)))
(new-env (reverse ur-env)))
(while (pair? rev-env)
- (set! new-env (cons (+ lastx (- lastx (cadr rev-env))) new-env))
+ (set! new-env (cons (- (+ lastx lastx) (cadr rev-env)) new-env))
(set! new-env (cons (car rev-env) new-env))
(set! rev-env (cddr rev-env)))
(reverse new-env))))
@@ -303,7 +302,7 @@ repetition to be in reverse."))
((= i times))
(do ((j 2 (+ j 2)))
((>= j len))
- (set! x (+ x (- (e j) (e (- j 2)))))
+ (set! x (- (+ x (e j)) (e (- j 2))))
(set! new-env (cons (e (+ j 1)) (cons x new-env))))
(if (and (< i (- times 1)) (not first-y-is-last-y))
(begin
@@ -433,8 +432,7 @@ each segment: (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))"))
(let* ((mn (min-envelope e))
(largest-diff (* 1.0 (- (max-envelope e) mn)))
(x-min (car e))
- (len (length e))
- (x-max (e (- len 2)))
+ (x-max (e (- (length e) 2)))
(x-incr (* 1.0 (/ (- x-max x-min) xgrid)))
(new-e ()))
(do ((x x-min (+ x x-incr)))
@@ -467,7 +465,7 @@ each segment: (powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))"))
(rms (make-moving-average incrsamps)) ; this could use make-moving-rms from dsp.scm
(rms-val 0.0)
(jend 0)
- (len (+ 1 (- end start)))
+ (len (- (+ end 1) start))
(data (make-float-vector len)))
(do ((i 0 (+ i 1)))
((= i len))
diff --git a/enved.scm b/enved.scm
index b3b658b..0ee7c77 100644
--- a/enved.scm
+++ b/enved.scm
@@ -62,29 +62,27 @@
pos
(search-point (cddr e) (+ pos 2)))))
- (define on-dot?
- (let ((mouse-radius .03))
- (lambda (x y cur-env pos)
- (and (pair? cur-env)
- (pair? (cdr cur-env))
- (or (and (< (abs (- (car cur-env) x)) mouse-radius)
- (< (abs (- (cadr cur-env) y)) mouse-radius)
- pos)
- (on-dot? x y (cddr cur-env) (+ pos 2)))))))
-
- (let* ((x (max 0.0 (min ux 1.0)))
- (y (max 0.0 (min uy 1.0)))
- (cur-env (channel-envelope snd chn))
- (pos (on-dot? x y cur-env 0)))
- (set! mouse-new (not pos))
- (set! mouse-down (get-internal-real-time))
- (if pos
- (set! mouse-pos pos)
- (let ((new-x (max 0.001 (min x .999))))
- (set! (channel-envelope snd chn)
- (add-envelope-point new-x y cur-env))
- (set! mouse-pos (envelope-position new-x (channel-envelope snd chn))))))))
-
+ (letrec ((on-dot? (let ((mouse-radius .03))
+ (lambda (x y cur-env pos)
+ (and (pair? cur-env)
+ (pair? (cdr cur-env))
+ (or (and (< (abs (- (car cur-env) x)) mouse-radius)
+ (< (abs (- (cadr cur-env) y)) mouse-radius)
+ pos)
+ (on-dot? x y (cddr cur-env) (+ pos 2))))))))
+ (let* ((x (max 0.0 (min ux 1.0)))
+ (y (max 0.0 (min uy 1.0)))
+ (cur-env (channel-envelope snd chn))
+ (pos (on-dot? x y cur-env 0)))
+ (set! mouse-new (not pos))
+ (set! mouse-down (get-internal-real-time))
+ (if pos
+ (set! mouse-pos pos)
+ (let ((new-x (max 0.001 (min x .999))))
+ (set! (channel-envelope snd chn)
+ (add-envelope-point new-x y cur-env))
+ (set! mouse-pos (envelope-position new-x (channel-envelope snd chn)))))))))
+
(define (mouse-drag-envelope hook)
(let ((snd (hook 'snd))
diff --git a/examp.scm b/examp.scm
index 557122e..614c6d0 100644
--- a/examp.scm
+++ b/examp.scm
@@ -82,7 +82,7 @@
(lambda* (snd chn)
(let ((wl (left-sample snd chn))
(wr (right-sample snd chn)))
- (channel->float-vector wl (+ 1 (- wr wl)) snd chn)))))
+ (channel->float-vector wl (- (+ wr 1) wl) snd chn)))))
(define display-energy
@@ -135,8 +135,7 @@
(let ((documentation "(window-rms) -> rms of data in currently selected graph window"))
(lambda ()
(let* ((ls (left-sample))
- (rs (right-sample))
- (data (channel->float-vector ls (+ 1 (- rs ls))))
+ (data (channel->float-vector ls (- (+ (right-sample) 1) ls)))
(len (length data)))
(sqrt (/ (dot-product data data) len))))))
@@ -183,10 +182,7 @@
(> (framples snd 1) 1)))
(status-report "display-correlation wants stereo input")
(let* ((ls (left-sample snd 0))
- (rs (right-sample snd 0))
- (ilen (+ 1 (- rs ls)))
- (pow2 (ceiling (log ilen 2)))
- (fftlen (floor (expt 2 pow2)))
+ (fftlen (floor (expt 2 (ceiling (log (- (+ (right-sample snd 0) 1) ls) 2)))))
(fftscale (/ 1.0 fftlen))
(rl1 (channel->float-vector ls fftlen snd 0))
(rl2 (channel->float-vector ls fftlen snd 1))
@@ -248,8 +244,7 @@
(+ 1 maxsync)))
(sounds))))))
(let* ((ls (left-sample snd chn))
- (rs (right-sample snd chn))
- (pow2 (ceiling (log (max 1 (- rs ls)) 2)))
+ (pow2 (ceiling (log (max 1 (- (right-sample snd chn) ls)) 2)))
(fftlen (floor (expt 2 pow2))))
(if (> pow2 2)
(let ((ffts ()))
@@ -466,23 +461,22 @@ read an ASCII sound file"))
(let* ((keysnd (or (selected-sound) (car (sounds))))
(keychn (or (selected-channel keysnd) 0))
(chan-marks (marks keysnd keychn)))
- (define find-leftmost-mark
- (let ((current-left-sample (left-sample keysnd keychn)))
- (lambda (samps)
- (and (pair? samps)
- (if (> (car samps) current-left-sample)
- (car samps)
- (find-leftmost-mark (cdr samps)))))))
- (if (null? chan-marks)
- (status-report "no marks!")
- (let ((leftmost (find-leftmost-mark (map mark-sample chan-marks))))
- (if (number? leftmost)
- (begin
- (set! (left-sample keysnd keychn) leftmost)
- keyboard-no-action)
- (status-report "no mark in window"))))))))
+ (letrec ((find-leftmost-mark (let ((current-left-sample (left-sample keysnd keychn)))
+ (lambda (samps)
+ (and (pair? samps)
+ (if (> (car samps) current-left-sample)
+ (car samps)
+ (find-leftmost-mark (cdr samps))))))))
+ (if (null? chan-marks)
+ (status-report "no marks!")
+ (let ((leftmost (find-leftmost-mark (map mark-sample chan-marks))))
+ (if (number? leftmost)
+ (begin
+ (set! (left-sample keysnd keychn) leftmost)
+ keyboard-no-action)
+ (status-report "no mark in window")))))))))
- ;(bind-key #\m 0 (lambda () "align window left edge with mark" (first-mark-in-window-at-left)))
+;; (bind-key #\m 0 (lambda () "align window left edge with mark" (first-mark-in-window-at-left)))
;;; -------- flash selected data red and green
@@ -780,8 +774,7 @@ then inverse ffts."))
(define fft-env-data
(let ((documentation "(fft-env-data fft-env snd chn) applies fft-env as spectral env to current sound, returning float-vector of new data"))
(lambda* (fft-env snd chn)
- (let* ((len (framples snd chn))
- (fsize (expt 2 (ceiling (log len 2))))
+ (let* ((fsize (expt 2 (ceiling (log (framples snd chn) 2))))
(rdata (channel->float-vector 0 fsize snd chn))
(idata (make-float-vector fsize))
(e (make-env (concatenate-envelopes fft-env (reverse-envelope fft-env)) :length fsize))
@@ -1089,9 +1082,8 @@ formants, then calls map-channel: (osc-formants .99 (float-vector 400.0 800.0 12
(define ring-mod
(let ((documentation "(ring-mod freq gliss-env) returns a time-varying ring-modulation filter: (map-channel (ring-mod 10 (list 0 0 1 (hz->radians 100))))"))
(lambda (freq gliss-env)
- (let* ((os (make-oscil :frequency freq))
- (len (framples))
- (genv (make-env gliss-env :length len)))
+ (let ((os (make-oscil :frequency freq))
+ (genv (make-env gliss-env :length (framples))))
(lambda (inval)
(* (oscil os (env genv)) inval))))))
@@ -1195,8 +1187,7 @@ to produce a sound at a new pitch but at the original tempo. It returns a funct
:jitter 0
:input (make-sampler 0 snd chn)))
(ge (make-env gr-env :duration dur))
- (sound-len (round (* (srate snd) dur)))
- (len (max sound-len (framples snd chn)))
+ (len (max (round (* (srate snd) dur)) (framples snd chn)))
(out-data (make-float-vector len)))
(do ((i 0 (+ i 1)))
((= i len))
diff --git a/expandn.scm b/expandn.scm
index ed77b86..6687441 100644
--- a/expandn.scm
+++ b/expandn.scm
@@ -47,15 +47,15 @@
(rampdata (if (pair? ramp) ramp (list 0 ramp 1 ramp)))
(start (floor (* input-start (mus-sound-srate fnam))))
(max-in-hop (/ max-out-hop min-exp-amt))
- (rev-mx (and *reverb* reverb (> reverb 0.0)
+ (rev-mx (and *reverb* (real? reverb) (> reverb 0.0)
(let* ((rchans (max out-chans rev-chans))
- (rmx (make-float-vector (list rchans rchans) 0.0)))
+ (rmx (make-float-vector (list rchans rchans))))
(do ((i 0 (+ i 1)))
((= i rchans))
(set! (rmx i i) reverb))
rmx))))
- (let ((mx (let ((v (make-float-vector (list ochans ochans) 0.0)))
+ (let ((mx (let ((v (make-float-vector (list ochans ochans))))
(if (pair? matrix)
(let ((mat-in (min ochans (length matrix)))
(mat-out (min ochans (length (car matrix)))))
@@ -69,7 +69,7 @@
(set! (v i i) 1.0)))
v))
- (revvals (and rev-mx (make-float-vector (max out-chans rev-chans) 0.0)))
+ (revvals (and rev-mx (make-float-vector (max out-chans rev-chans))))
(update-envs (or (pair? expand)
(pair? seglen)
(pair? ramp)
@@ -96,8 +96,8 @@
(max-len (ceiling (* *clm-srate*
(+ (max max-out-hop max-in-hop)
max-seg-len))))
- (invals (make-float-vector ochans 0.0))
- (outvals (make-float-vector ochans 0.0)))
+ (invals (make-float-vector ochans))
+ (outvals (make-float-vector ochans)))
(if (or minramp-bug maxramp-bug)
(error 'out-of-range (list expand
@@ -130,9 +130,8 @@
(not rev-mx))
(let ((file-end (+ beg (seconds->samples (+ (* 2 seglen)
- (* (mus-sound-duration fnam)
- (/ (mus-sound-srate fnam) *clm-srate*)
- (/ expand srate)))))))
+ (/ (* (mus-sound-duration fnam) (mus-sound-srate fnam) expand)
+ *clm-srate* srate))))))
(set! end (min end file-end))
(do ((i beg (+ i 1)))
@@ -279,8 +278,8 @@
(if rev-mx
(frample->file *reverb* i (frample->frample rev-mx outvals ochans revvals rev-chans)))))
- (let ((samples-0 (make-float-vector in-chans 0.0))
- (samples-1 (make-float-vector in-chans 0.0)))
+ (let ((samples-0 (make-float-vector in-chans))
+ (samples-1 (make-float-vector in-chans)))
;; more than 2 chans in input file
(do ((i beg (+ i 1)))
((= i end))
diff --git a/extensions.scm b/extensions.scm
index 745b131..7d2da9f 100644
--- a/extensions.scm
+++ b/extensions.scm
@@ -547,10 +547,8 @@ connects them with 'func', and applies the result as an amplitude envelope to th
(define channels-equal?
(let ((documentation "(channels-equal? s1 c1 s2 c2 (diff 0.0)) -> #t if the two channels are the same (within diff)"))
(lambda* (snd1 chn1 snd2 chn2 (allowable-difference 0.0))
- (let ((len1 (framples snd1 chn1))
- (len2 (framples snd2 chn2)))
- (and (= len1 len2)
- (channels=? snd1 chn1 snd2 chn2 allowable-difference))))))
+ (and (= (framples snd1 chn1) (framples snd2 chn2))
+ (channels=? snd1 chn1 snd2 chn2 allowable-difference)))))
;;; -------- mono->stereo, mono-files->stereo
diff --git a/extsnd.html b/extsnd.html
index a9a6614..cf72cda 100644
--- a/extsnd.html
+++ b/extsnd.html
@@ -3092,10 +3092,10 @@ reported it via the hook).
<pre class="indented">
(define without-warnings
(lambda (thunk)
- (define no-warning (lambda (hook) (set! (hook 'result) #t)))
- (hook-push <em class=red>snd-warning-hook</em> no-warning)
- (thunk)
- (hook-remove <em class=red>snd-warning-hook</em> no-warning)))
+ (let ((no-warning (lambda (hook) (set! (hook 'result) #t))))
+ (hook-push <em class=red>snd-warning-hook</em> no-warning)
+ (thunk)
+ (hook-remove <em class=red>snd-warning-hook</em> no-warning))))
</pre>
<div class="spacer"></div>
@@ -3531,7 +3531,7 @@ in the Scheme, Ruby, and Forth files.
((< chn (channels reg))
(let* ((reader (<em class=red>make-region-sampler</em> 0 reg chn))
(len (region-framples reg))
- (data (make-float-vector len 0.0)))
+ (data (make-float-vector len)))
(do ((i 0 (+ i 1)))
((= i len) data)
(set! (data i) (<em class=red>reader</em>)))))
@@ -7739,7 +7739,7 @@ To get the data currently displayed in the time domain window:
(define (<a class=quiet href="sndscm.html#windowsamples">window-samples</a>)
(let ((wl (<em class=red>left-sample</em>))
(wr (<a href="#rightsample">right-sample</a>)))
- (<a href="#samples">samples</a> wl (+ 1 (- wr wl)))))
+ (<a href="#samples">samples</a> wl (- (+ wr 1) wl))))
</pre>
<p id="movingwindows">See also <a href="#moveonepixel">move-one-pixel</a>.
@@ -8644,7 +8644,7 @@ reversed reverb. As a hack, you can reverse a sound (modulo a one sample rotati
(let* ((len (<a class=quiet href="#framples">framples</a> snd 0))
(fsize (expt 2 (ceiling (log len 2))))
(rl (channel->float-vector 0 fsize snd 0))
- (im (make-float-vector fsize 0.0)))
+ (im (make-float-vector fsize)))
(<a class=quiet href="sndclm.html#fft">mus-fft</a> rl im fsize)
(<a class=quiet href="sndclm.html#fft">mus-fft</a> rl im fsize)
(float-vector-scale! rl (/ 1.0 fsize))
@@ -8950,7 +8950,7 @@ There are approximately a bazillion ways to scale samples in Snd; here's a potpo
(begin (<a class=quiet href="#selectall">select-all</a>) (<a class=quiet href="#scaleselectionby">scale-selection-by</a> 2.0))
(begin (<a class=quiet href="#savesoundas">save-sound-as</a> "temp.snd") (<a class=quiet href="#mix">mix</a> "temp.snd" 0) (delete-file "temp.snd"))
-(let ((flt (make-float-vector 8 0.0)))
+(let ((flt (make-float-vector 8)))
(set! (flt 0) 2.0)
(let ((cnv (<a class=quiet href="sndclm.html#make-convolve">make-convolve</a> :filter flt))
(sf (<a class=quiet href="#makesampler">make-sampler</a> 0)))
@@ -8964,7 +8964,7 @@ There are approximately a bazillion ways to scale samples in Snd; here's a potpo
(let* ((len (<a class=quiet href="#framples">framples</a>))
(fsize (expt 2 (ceiling (/ (log len) (log 2)))))
(rl (channel->float-vector 0 fsize))
- (im (make-float-vector fsize 0.0)))
+ (im (make-float-vector fsize)))
(<a class=quiet href="sndclm.html#fft">mus-fft</a> rl im fsize)
(<a class=quiet href="sndclm.html#fft">mus-fft</a> rl im fsize)
(<a class=quiet href="sndclm.html#fft">mus-fft</a> rl im fsize)
@@ -9299,7 +9299,7 @@ the end points:
<pre class="indented">
(define (smoother y0 y1 num)
- (let ((v (make-float-vector (+ 1 num) 0.0))
+ (let ((v (make-float-vector (+ 1 num)))
(angle (if (> y1 y0) pi 0.0))
(off (* .5 (+ y0 y1)))
(scale (* 0.5 (abs (- y1 y0)))))
@@ -9686,9 +9686,7 @@ how long the resultant note will be given an src envelope:
(define (<em class="noem">src-duration</em> e)
(let* ((len (length e))
- (ex0 (e 0))
- (ex1 (e (- len 2)))
- (all-x (- ex1 ex0))
+ (all-x (- (e (- len 2)) (e 0))) ; last x - first x
(dur 0.0))
(do ((i 0 (+ i 2)))
((>= i (- len 2)) dur)
@@ -11295,7 +11293,7 @@ Here's an example that displays a histogram of the current values in 16 bins:
<pre class="indented">
(<em class=red>add-transform</em> "histogram" "bins" 0.0 1.0
(lambda (len fd)
- (let ((v (make-float-vector len 0.0))
+ (let ((v (make-float-vector len))
(steps (/ len 16))
(step (/ 1.0 len)))
(do ((i 0 (+ i 1)))
@@ -11313,7 +11311,7 @@ Here's an example that displays a histogram of the current values in 16 bins:
<pre class="indented">
(<em class=red>add-transform</em> "Hankel" "Hankel" 0.0 1.0
(lambda (n rd)
- (let ((v (make-float-vector n 0.0)))
+ (let ((v (make-float-vector n)))
(do ((i 0 (+ i 1))) ((= i n)) (set! (v i) (rd)))
(gsl-dht n v 1.0 1.0)
v)))
@@ -13764,9 +13762,9 @@ of FractInt's royal colormap):
<pre class="indented">
(add-colormap "purple"
(lambda (size)
- (do ((r (make-float-vector size 0.0))
- (g (make-float-vector size 0.0))
- (b (make-float-vector size 0.0))
+ (do ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
(incr (/ 256.0 size))
(er (list 0 60 60 116 128 252 192 252 256 60))
(eg (list 0 0 64 0 128 252 192 252 256 0))
@@ -13782,9 +13780,9 @@ of FractInt's royal colormap):
;;; another amusing colormap from FractInt:
(add-colormap "cos"
(lambda (size)
- (do ((r (make-float-vector size 0.0))
- (g (make-float-vector size 0.0))
- (b (make-float-vector size 0.0))
+ (do ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
(incr (/ 3.14159 size))
(i 0 (+ i 1))
(x 0.0 (+ x incr)))
@@ -14380,11 +14378,9 @@ in to make sure the font color reflects whether we're in the selected channel:
</p>
<pre class="indented">
- (XSetFont dpy
- (if (= chn (<a class=quiet href="#selectedsound">selected-channel</a> snd))
- (cadr (snd-gcs))
- (car (snd-gcs)))
- (.fid fs))
+(XSetFont dpy
+ ((if (= chn (<a class=quiet href="#selectedsound">selected-channel</a> snd)) cadr car) (snd-gcs))
+ (.fid fs))
</pre>
<div class="spacer"></div>
diff --git a/fade.scm b/fade.scm
index 2f922bc..78ef28c 100644
--- a/fade.scm
+++ b/fade.scm
@@ -51,7 +51,7 @@
(let ((bank2-end (+ bank2-start bank-samps))
(ramp 0.0)
(outval 0.0)
- (inputs (make-float-vector fs 0.0))
+ (inputs (make-float-vector fs))
(ifs (/ 1.0 fs))
(mid 0))
@@ -168,9 +168,9 @@
(fs (make-vector freq-inc #f))
(amps (make-float-vector freq-inc amp))
(ctr 0)
- (inputs (make-float-vector freq-inc 0.0))
+ (inputs (make-float-vector freq-inc))
(ramps (make-vector freq-inc -1))
- (in2s (make-int-vector freq-inc 0))
+ (in2s (make-int-vector freq-inc))
(in2-ctr 0)
(ramp-ctr 0))
diff --git a/fft-menu.scm b/fft-menu.scm
index d9dcf8b..218e71c 100644
--- a/fft-menu.scm
+++ b/fft-menu.scm
@@ -83,17 +83,14 @@ removes all energy below the low frequency and above the high frequency, then co
(add-sliders
fft-edit-dialog
- (list (list "low frequency" 20 initial-fft-edit-low-frequency 22050
- (if (provided? 'snd-gtk)
- (lambda (w data) (set! fft-edit-low-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! fft-edit-low-frequency ((*motif* '.value) info))))
- 1)
-
- (list "high frequency" 20 initial-fft-edit-high-frequency 22050
- (if (provided? 'snd-gtk)
- (lambda (w data) (set! fft-edit-high-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
- (lambda (w context info) (set! fft-edit-high-frequency ((*motif* '.value) info))))
- 1))))))
+ (list (let ((low-func (if (provided? 'snd-gtk)
+ (lambda (w data) (set! fft-edit-low-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! fft-edit-low-frequency ((*motif* '.value) info))))))
+ (list "low frequency" 20 initial-fft-edit-low-frequency 22050 low-func 1))
+ (let ((high-func (if (provided? 'snd-gtk)
+ (lambda (w data) (set! fft-edit-high-frequency ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w))))
+ (lambda (w context info) (set! fft-edit-high-frequency ((*motif* '.value) info))))))
+ (list "high frequency" 20 initial-fft-edit-high-frequency 22050 high-func 1)))))))
(activate-dialog fft-edit-dialog))
(set! fft-edit-menu-label (add-to-menu fft-menu "FFT notch filter" post-fft-edit-dialog))))
@@ -151,13 +148,12 @@ removes all energy below the low frequency and above the high frequency, then co
(set! sliders
(add-sliders
fft-squelch-dialog
- (list (list "squelch amount" 0.0 initial-fft-squelch-amount 1.0
- (if (provided? 'snd-gtk)
- (lambda (w data)
- (set! fft-squelch-amount (/ ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)) 100)))
- (lambda (w context info)
- (set! fft-squelch-amount (/ ((*motif* '.value) info) 100))))
- 100))))))
+ (let ((squelch-func (if (provided? 'snd-gtk)
+ (lambda (w data)
+ (set! fft-squelch-amount (/ ((*gtk* 'gtk_adjustment_get_value) ((*gtk* 'GTK_ADJUSTMENT) w)) 100)))
+ (lambda (w context info)
+ (set! fft-squelch-amount (/ ((*motif* '.value) info) 100))))))
+ (list (list "squelch amount" 0.0 initial-fft-squelch-amount 1.0 squelch-func 100)))))))
(activate-dialog fft-squelch-dialog))
(set! fft-squelch-menu-label (add-to-menu fft-menu "FFT squelch" post-fft-squelch-dialog))))
diff --git a/fmv.scm b/fmv.scm
index b3b9d5c..e094601 100644
--- a/fmv.scm
+++ b/fmv.scm
@@ -69,7 +69,7 @@ fm-violin takes the value returned by make-fm-violin and returns a new sample ea
(maxdev (* frq-scl fm-index))
(logfreq (log frequency))
(index1 (or fm1-index (min pi (* maxdev (/ 5.0 logfreq)))))
- (index2 (or fm2-index (min pi (* maxdev 3.0 (/ (- 8.5 logfreq) (+ 3.0 (* frequency .001)))))))
+ (index2 (or fm2-index (min pi (/ (* maxdev 3.0 (- 8.5 logfreq)) (+ 3.0 (* frequency 0.001))))))
(index3 (or fm3-index (min pi (* maxdev (/ 4.0 (sqrt frequency))))))
(easy-case (and (zero? noise-amount)
(or (not fm2-env) (equal? fm1-env fm2-env))
@@ -104,7 +104,7 @@ fm-violin takes the value returned by make-fm-violin and returns a new sample ea
(lambda ()
(let ((vib (+ (frqf) (triangle-wave pervib) (rand-interp ranvib)))
- (fuzz (if fm-noi (rand fm-noi) 0.0)))
+ (fuzz (if (rand? fm-noi) (rand fm-noi) 0.0)))
(* (ampf)
(if amp-noi (+ 1.0 (rand-interp amp-noi)) 1.0)
(oscil carrier
diff --git a/freeverb.scm b/freeverb.scm
index dc9a809..fe6e043 100644
--- a/freeverb.scm
+++ b/freeverb.scm
@@ -66,9 +66,9 @@
(numallpasses (length allpasstuning)))
(let ((beg (seconds->samples startime))
(end (seconds->samples (+ startime dur)))
- (out-buf (make-float-vector out-chans 0.0))
- (f-out (make-float-vector out-chans 0.0))
- (f-in (make-float-vector in-chans 0.0))
+ (out-buf (make-float-vector out-chans))
+ (f-out (make-float-vector out-chans))
+ (f-in (make-float-vector in-chans))
(predelays (make-vector in-chans))
(fcombs (make-vector (* out-chans numcombs)))
(allpasses (make-vector (* out-chans numallpasses)))
@@ -89,7 +89,7 @@
(error "input must be mono or input channels must equal output channels"))
(let ((out-mix (or output-mixer
- (let ((v (make-float-vector (list out-chans out-chans) 0.0)))
+ (let ((v (make-float-vector (list out-chans out-chans))))
(do ((i 0 (+ i 1)))
((= i out-chans))
(do ((j 0 (+ j 1)))
diff --git a/fullmix.scm b/fullmix.scm
index 03d757e..53c1b1f 100644
--- a/fullmix.scm
+++ b/fullmix.scm
@@ -14,10 +14,10 @@
(let ((st (seconds->samples (or beg 0.0)))
(dur (or outdur
(/ (- (mus-sound-duration in-file) (or inbeg 0.0))
- (or (and srate (number? srate) (abs srate)) 1.0))))
+ (or (and (real? srate) (abs srate)) 1.0))))
(in-chans (channels in-file))
(out-chans (channels *output*))
- (reversed (or (and (number? srate) (negative? srate))
+ (reversed (or (and (real? srate) (negative? srate))
(and (pair? srate) (pair? (cdr srate)) (negative? (cadr srate)))))
(inloc (floor (* (or inbeg 0.0) (mus-sound-srate in-file)))))
@@ -25,14 +25,14 @@
(let ((samps (seconds->samples dur))
(mx (let ((ochans (max in-chans out-chans)))
(if matrix
- (make-float-vector (list ochans ochans) 0.0)
- (let ((v (make-float-vector (list ochans ochans) 0.0)))
+ (make-float-vector (list ochans ochans))
+ (let ((v (make-float-vector (list ochans ochans))))
(do ((i 0 (+ i 1)))
((= i ochans))
(set! (v i i) 1.0))
v))))
- (rev-mx (and *reverb* reverb-amount (> reverb-amount 0.0)
- (let ((rmx (make-float-vector (list in-chans in-chans) 0.0)))
+ (rev-mx (and *reverb* (real? reverb-amount) (> reverb-amount 0.0)
+ (let ((rmx (make-float-vector (list in-chans in-chans))))
(do ((i 0 (+ i 1)))
((= i in-chans))
(set! (rmx i 0) reverb-amount)) ; 0->assume 1 chan reverb stream, I think
@@ -95,7 +95,7 @@
(let ((srcs (make-vector in-chans #f)))
(do ((inp 0 (+ inp 1)))
((= inp in-chans))
- (vector-set! srcs inp (make-src :input (vector-ref file inp) :srate (if (number? srate) (abs srate) 0.0))))
+ (vector-set! srcs inp (make-src :input (vector-ref file inp) :srate (if (real? srate) (abs srate) 0.0))))
(mus-file-mix-with-envs file st samps mx rev-mx envs srcs srcenv *output* *reverb*)
)))))
diff --git a/generators.scm b/generators.scm
index e95bcb3..c277be1 100644
--- a/generators.scm
+++ b/generators.scm
@@ -350,12 +350,10 @@ returns n sines from frequency spaced by frequency * ratio with every other sine
:make-wrapper (lambda (g)
(if (< (g 'n) 1) (set! (g 'n) 1))
(set! (g 'frequency) (hz->radians (g 'frequency)))
- (if (and (< (g 'n) 100)
- (> (noddsin-maxes (g 'n)) 0.0))
- (set! (g 'norm) (/ 1.0 (noddsin-maxes (g 'n))))
- (begin
- (set! (noddsin-maxes (g 'n)) (find-noddsin-max (g 'n)))
- (set! (g 'norm) (/ 1.0 (noddsin-maxes (g 'n))))))
+ (if (not (and (< (g 'n) 100)
+ (> (noddsin-maxes (g 'n)) 0.0)))
+ (set! (noddsin-maxes (g 'n)) (find-noddsin-max (g 'n))))
+ (set! (g 'norm) (/ 1.0 (noddsin-maxes (g 'n))))
g))
(frequency *clm-default-frequency*) (n 1) (angle 0.0) (norm 1.0) fm)
@@ -844,8 +842,8 @@ returns n cosines spaced by frequency with amplitudes scaled by r^k."))
(set! angle (+ angle fm frequency))
(if trouble
0.0
- (/ (+ (- rcos (* e1 (cos (* n x))) rr)
- (* e2 (cos (* (- n 1) x))))
+ (/ (- (+ rcos (* e2 (cos (* (- n 1) x))))
+ (* e1 (cos (* n x))) rr)
(* norm (+ r1 (* -2.0 rcos))))))))))
;; it's faster to use polywave here and nrcos->polywave for the partials list (animals.scm) if n is not enormous
@@ -1038,8 +1036,8 @@ scaled by r^k. The 'interp' argument determines whether the sidebands are above
(result (* vol
(+ (* (- relamp vola)
(nrssb-interp gen (* res1 vib) -1.0))
- (* (+ (- 1.0 relamp) vola)
- (oscil gen2 (+ (* vib res2)
+ (* (- (+ 1.0 vola) relamp)
+ (oscil gen2 (+ (* vib res2)
(* hfreq (oscil gen3 vib)))))))))
(outa i result)
(if *reverb* (outa i (* .01 result) *reverb*)))))))
@@ -2215,8 +2213,7 @@ returns many cosines from spaced by frequency with amplitude e^(-r)."))
(lambda* (gen (fm 0.0))
(let-set! gen 'fm fm)
(with-let gen
- (let* ((a r)
- (sinha (sinh a)))
+ (let ((sinha (sinh r)))
(if (zero? sinha)
0.0 ; just a guess
(/ (atan (oscil osc fm) sinha)
@@ -3047,8 +3044,7 @@ returns many sinusoids from frequency spaced by frequency * 2 * ratio with ampli
|#
(definstrument (glassy beg dur freq amp)
- (let* ((n (floor (/ *clm-srate* (* 3 freq))))
- (r (expt .001 (/ n))))
+ (let ((r (expt .001 (/ (floor (/ *clm-srate* (* 3 freq)))))))
(let ((start (seconds->samples beg))
(stop (seconds->samples (+ beg dur)))
(clang (make-rkoddssb (* freq 2) (/ 1.618 2) r))
@@ -3318,15 +3314,14 @@ returns many cosines spaced by frequency with amplitude 1/(r^2+k^2)."))
(lambda* (gen (fm 0.0))
(let-set! gen 'fm fm)
(with-let gen
- (let ((x angle)
- (a r))
+ (let ((x angle))
(if (> x (* 2 pi))
(set! x (modulo x (* 2 pi))))
(set! angle (+ x fm frequency))
- (/ (- (* pi (/ (cosh (* a (- pi x)))
- (sinh (* a pi))))
- (/ a))
- (* 2 a (r2k2cos-norm a))))))))
+ (/ (- (* pi (/ (cosh (* r (- pi x)))
+ (sinh (* r pi))))
+ (/ r))
+ (* 2 r (r2k2cos-norm r))))))))
#|
(with-sound (:clipped #f :statistics #t :play #t)
@@ -3697,13 +3692,12 @@ returns a sum of cosines scaled Jk^2(index/2)."))
(let-set! gen 'fm fm)
(with-let gen
(let* ((x angle)
- (z index)
- (j0 (bes-j0 (* 0.5 z)))
+ (j0 (bes-j0 (* 0.5 index)))
(dc (* j0 j0)))
(set! angle (+ angle fm frequency))
(if (= dc 1.0)
1.0
- (/ (- (bes-j0 (* z (sin x)))
+ (/ (- (bes-j0 (* index (sin x)))
dc) ; get rid of DC component
(- 1.0 dc)))))))) ; normalize
@@ -3823,8 +3817,7 @@ returns a sum of cosines scaled in a very complicated way."))
(lambda* (gen (fm 0.0))
(let-set! gen 'fm fm)
(with-let gen
- (let* ((x angle)
- (rsinx2 (* 2.0 r (sin (* 0.5 x)))))
+ (let ((rsinx2 (* 2.0 r (sin (* 0.5 angle)))))
(set! angle (+ angle fm frequency))
(if (< (abs rsinx2) nearly-zero)
1.0
@@ -3867,15 +3860,14 @@ returns a sum of cosines scaled in a very complicated way."))
(lambda* (gen (fm 0.0))
(let-set! gen 'fm fm)
(with-let gen
- (let* ((x angle)
- ;; (dc (/ (* (sin (* k a)) (sin (* k r))) (* k a r)))
- ;; from P0(x)=1, J[1/2](x)=sqrt(2/(pi x))sin(x), omitting original 1/pi
- ;; G&R 914 (8.464), 974 (8.912), but it's missing some remaining (small) component
- ;; also omitting the original divide by (* pi (sqrt arg)) -- it's just an amplitude scaler
- ;; and in this context, we get -1..1 peak amps from the sin anyway.
- (arg (+ (* r r)
+ ;; (dc (/ (* (sin (* k a)) (sin (* k r))) (* k a r)))
+ ;; from P0(x)=1, J[1/2](x)=sqrt(2/(pi x))sin(x), omitting original 1/pi
+ ;; G&R 914 (8.464), 974 (8.912), but it's missing some remaining (small) component
+ ;; also omitting the original divide by (* pi (sqrt arg)) -- it's just an amplitude scaler
+ ;; and in this context, we get -1..1 peak amps from the sin anyway.
+ (let ((arg (+ (* r r)
(* a a)
- (* a -2.0 r (cos x)))))
+ (* a -2.0 r (cos angle)))))
(set! angle (+ angle fm frequency))
(if (< (abs arg) nearly-zero) ; r = a, darn it! This will produce a spike, but at least it's not a NaN
1.0
@@ -3983,10 +3975,9 @@ returns a sum of cosines scaled in a very complicated way."))
(let-set! gen 'fm fm)
(with-let gen
(let* ((x angle)
- (z index)
- (j0 (bes-j0 (* 0.5 z)))
+ (j0 (bes-j0 (* 0.5 index)))
(dc (* j0 j0))
- (arg (* z (cos x))))
+ (arg (* index (cos x))))
(set! angle (+ angle fm frequency))
(/ (- (+ (bes-j0 arg)
(bes-j1 arg))
@@ -4079,15 +4070,11 @@ returns a sum of cosines scaled by Yn(r)*Jn(r)."))
(let-set! gen 'fm fm)
(with-let gen
(let* ((x angle)
- (b r)
- (c a)
- (b2c2 (+ (* b b) (* c c)))
- (dc (* (bes-y0 b) (bes-j0 c)))
- (norm (abs (- (bes-y0 (sqrt (+ b2c2 (* -2 b c)))) dc))))
+ (b2c2 (+ (* r r) (* a a)))
+ (dc (* (bes-y0 r) (bes-j0 a)))
+ (norm (abs (- (bes-y0 (sqrt (+ b2c2 (* -2 r a)))) dc))))
(set! angle (+ angle fm frequency))
- (/ (- (bes-y0 (sqrt (+ b2c2 (* -2.0 b c (cos x)))))
- dc)
- norm))))))
+ (/ (- (bes-y0 (sqrt (+ b2c2 (* -2.0 r a (cos x))))) dc) norm))))))
;;; oops -- bes-y0(0) is -inf!
;;; norm only works for "reasonable" a and r
@@ -4523,7 +4510,7 @@ returns the nth Blackman-Harris fft data window as a periodic waveform. (n <= 10
(set! (g 'coeffs) (float-vector 0.0
(/ (* pi pi) 6.0)
(/ pi -4.0)
- (/ 12.0)))
+ 0.08333)) ; (/ 12.0)
g)
:methods k3sin-methods)
(frequency *clm-default-frequency*) (angle 0.0) (coeffs #f) fm)
@@ -4624,9 +4611,9 @@ returns the nth Blackman-Harris fft data window as a periodic waveform. (n <= 10
(do ((i 0 (+ i 1)))
((= i 3))
(let* ((frq (* freq (expt 2 i)))
- (index1 (hz->radians (* fm-index frq (/ 5.0 (log frq)))))
- (index2 (hz->radians (* fm-index frq 3.0 (/ (- 8.5 (log frq)) (+ 3.0 (* frq .001))))))
- (index3 (hz->radians (* fm-index frq (/ 4.0 (sqrt frq))))))
+ (index1 (hz->radians (/ (* fm-index frq 5.0) (log frq))))
+ (index2 (hz->radians (/ (* fm-index frq 3.0 (- 8.5 (log frq))) (+ 3.0 (* frq 0.001)))))
+ (index3 (hz->radians (/ (* fm-index frq 4.0) (sqrt frq)))))
(set! (carriers i) (make-oscil frq))
(set! (fmoscs i) (make-polywave frq
:partials (list 1 index1
@@ -5695,20 +5682,19 @@ returns the sum of the last n inputs weighted by (-n/(n+1))^k"))
(define polyoid-un mus-ycoeffs)
(define* (make-polyoid (frequency *clm-default-frequency*) partial-amps-and-phases)
- (let* ((lst partial-amps-and-phases)
- (len (length lst))
+ (let* ((len (length partial-amps-and-phases))
(topk (let ((n 0))
(do ((i 0 (+ i 3)))
((>= i len))
- (set! n (max n (floor (lst i)))))
+ (set! n (max n (floor (partial-amps-and-phases i)))))
n))
- (sin-amps (make-float-vector (+ topk 1) 0.0))
- (cos-amps (make-float-vector (+ topk 1) 0.0)))
+ (sin-amps (make-float-vector (+ topk 1)))
+ (cos-amps (make-float-vector (+ topk 1))))
(do ((j 0 (+ j 3)))
((>= j len))
- (let ((n (floor (lst j)))
- (amp (lst (+ j 1)))
- (phase (lst (+ j 2))))
+ (let ((n (floor (partial-amps-and-phases j)))
+ (amp (partial-amps-and-phases (+ j 1)))
+ (phase (partial-amps-and-phases (+ j 2))))
(if (> n 0) ; constant only applies to cos side
(set! (sin-amps n) (* amp (cos phase))))
(set! (cos-amps n) (* amp (sin phase)))))
@@ -5876,15 +5862,14 @@ returns the sum of the last n inputs weighted by (-n/(n+1))^k"))
(let ((min-dat (vector-find-if
(lambda (val)
- (and val
- (vector? val)
+ (and (vector? val)
(= (val 0) n)
(let* ((a-val (val 1))
(a-len (length val))
(a-data (list a-val (val 2))))
(do ((k 2 (+ k 1)))
((= k a-len))
- (if (and (number? (val k))
+ (if (and (real? (val k))
(< (val k) a-val))
(begin
(set! a-val (val k))
@@ -6425,13 +6410,12 @@ The magnitudes are available as mus-xcoeffs, the phases as mus-ycoeffs, and the
(if (< (linear->db rms) dbfloor)
(set! curval 0.0)
(let* ((data (mus-data dly))
- (n size)
- (fft2 (/ n 2))
+ (fft2 (/ size 2))
(numsum 0.0)
(densum 0.0))
(fill! im 0.0)
- (float-vector-subseq data 0 (- n 1) rl)
- (mus-fft rl im n 1) ; we can use the delay line contents un-reordered because phases are ignored here
+ (float-vector-subseq data 0 (- size 1) rl)
+ (mus-fft rl im size 1) ; we can use the delay line contents un-reordered because phases are ignored here
(rectangular->magnitudes rl im)
(do ((k 0 (+ k 1)))
((= k fft2))
@@ -6713,12 +6697,10 @@ input from the readin generator 'reader'. The output data is available via mus-
(dly2 (max 0.0 pos))
(frac2 (- dly2 (floor dly2)))
(loc outloc)
- (size maxd)
- (loc10 (modulo (+ loc (floor dly1)) size))
- (loc11 (modulo (+ loc 1 (floor dly1)) size))
- (loc20 (modulo (+ loc (floor dly2)) size))
- (loc21 (modulo (+ loc 1 (floor dly2)) size))
- (rev reverb-amount))
+ (loc10 (modulo (+ loc (floor dly1)) maxd))
+ (loc11 (modulo (+ loc 1 (floor dly1)) maxd))
+ (loc20 (modulo (+ loc (floor dly2)) maxd))
+ (loc21 (modulo (+ loc 1 (floor dly2)) maxd)))
(set! (out1 loc10) (+ (out1 loc10) (* amp1 input (- 1.0 frac1))))
(set! (out1 loc11) (+ (out1 loc11) (* amp1 input frac1)))
@@ -6730,13 +6712,13 @@ input from the readin generator 'reader'. The output data is available via mus-
(set! (out1 loc) 0.0)
(set! (out2 loc) 0.0)
(set! loc (+ loc 1))
- (if (= loc size) (set! loc 0))
+ (if (= loc maxd) (set! loc 0))
(outa samp val1)
(outb samp val2)
- (if (> rev 0.0)
+ (if (> reverb-amount 0.0)
(begin
- (outa samp (* rev val1) *reverb*)
- (outb samp (* rev val2) *reverb*)))
+ (outa samp (* reverb-amount val1) *reverb*)
+ (outb samp (* reverb-amount val2) *reverb*)))
(set! outloc loc)))))
diff --git a/gl.c b/gl.c
index 77303d0..ae42a08 100644
--- a/gl.c
+++ b/gl.c
@@ -5721,7 +5721,7 @@ void Init_libgl(void)
define_integers();
define_functions();
Xen_provide_feature("gl");
- Xen_define("gl-version", C_string_to_Xen_string("05-May-16"));
+ Xen_define("gl-version", C_string_to_Xen_string("13-Jun-16"));
gl_already_inited = true;
}
}
diff --git a/grani.scm b/grani.scm
index 5b61db6..9b2329a 100644
--- a/grani.scm
+++ b/grani.scm
@@ -48,16 +48,17 @@
(ycutoff (and cutoff (expt base (+ offset (* cutoff scaler)))))
(result ()))
- ;; linear interpolation
- (define (interpolate xl yl xh yh xi)
- (+ yl (* (- xi xl) (/ (- yh yl) (- xh xl)))))
-
;; recursively render one segment
;; xl,xh = x coordinates of segment ends
;; yl,yh = y coordinates of segment ends
;; yle,yhe = exponential values of y coords of segment ends
;; error = linear domain error bound for rendering
(define (exp-seg xl yle xh yhe yl yh error)
+
+ ;; linear interpolation
+ (define (interpolate xl yl xh yh xi)
+ (+ yl (* (- xi xl) (/ (- yh yl) (- xh xl)))))
+
(let* ((xint (/ (+ xl xh) 2.0))
(yint (interpolate xl yl xh yh xint))
(yinte (interpolate xl yle xh yhe xint))
@@ -66,14 +67,14 @@
;; is the linear approximation accurate enough?
;; are we still over the cutoff limit?
(if (not (and (> (abs (- yexp yinte)) yerr)
- (or (not ycutoff)
+ (or (not (real? ycutoff))
(> yinte ycutoff))))
;; yes --> don't need to add nu'ting to the envelope
(values () ())
;; no --> add a breakpoint and recurse right and left
((lambda (xi yi xj yj)
- (values (append xi (list xint) xj)
- (append yi (list yexp) yj)))
+ (values (append xi (cons xint xj))
+ (append yi (cons yexp yj))))
(exp-seg xl yle xint yexp yl yint error)
(exp-seg xint yexp xh yhe yint yh error)))))
@@ -85,7 +86,7 @@
(ny (* 1.0 (cadddr en)))
(yscl (+ offset (* y scaler)))
(nyscl (+ offset (* ny scaler)))
- (xy (list x (if (or (not ycutoff)
+ (xy (list x (if (or (not (real? ycutoff))
(>= (expt base yscl) ycutoff))
(* out-scaler (expt base yscl))
0.0))))
@@ -101,7 +102,7 @@
(vals (cdr xx) (cdr yy)))))))
(exp-seg x (expt base yscl) nx (expt base nyscl) yscl nyscl error))
(if (<= (length en) 4)
- (append result (list nx (if (or (not ycutoff)
+ (append result (list nx (if (or (not (real? ycutoff))
(>= (expt base nyscl) ycutoff))
(* out-scaler (expt base nyscl))
0.0)))
@@ -247,15 +248,13 @@
(let* ((v (make-float-vector len))
(active (* len duty-cycle 0.01))
(incr (/ pi (- active 1)))
- (start (/ (- len active) 2))
- (end (/ (+ len active) 2))
- (s 0))
- (do ((i 0 (+ 1 i)))
- ((= i len) v)
- (if (and (>= i start) (< i end))
- (let ((sine (sin (* s incr))))
- (set! s (+ 1 s))
- (set! (v i) (* sine sine)))))))
+ (start (max 0 (/ (- len active) 2)))
+ (end (min len (/ (+ len active) 2))))
+ (do ((i start (+ i 1))
+ (s 0.0 (+ s incr)))
+ ((= i end) v)
+ (let ((sine (sin s)))
+ (set! (v i) (* sine sine))))))
;;;=============================================================================
;;; Granular synthesis instrument
diff --git a/gtk-effects-utils.scm b/gtk-effects-utils.scm
index 49ba280..c0e5aae 100644
--- a/gtk-effects-utils.scm
+++ b/gtk-effects-utils.scm
@@ -141,14 +141,13 @@
(eq? (slider-data 6) 'log)))
(hbox (and use-hbox (gtk_box_new GTK_ORIENTATION_HORIZONTAL 0)))
(label (gtk_label_new
- (if use-hbox
- (format #f (if use-hbox
- (if use-log
- (values "~A: ~,2F" title initial)
- (values "~A:" title))
- (if use-log
- (values "~A (~,2F)" title initial)
- (values "~A" title)))))))
+ (format #f (if use-hbox
+ (if use-log
+ (values "~A: ~,2F" title initial)
+ (values "~A:" title))
+ (if use-log
+ (values "~A (~,2F)" title initial)
+ (values "~A" title))))))
(adj (if use-log
(gtk_adjustment_new (scale-log->linear low initial high) 0 log-scale-ticks 1 10 1)
(gtk_adjustment_new initial low high 0.0 0.0 0.0)))
@@ -173,16 +172,15 @@
(gtk_grid_attach (GTK_GRID table) scale 1 slider 1 1)
(set! slider (+ 1 slider))))
(gtk_widget_show scale)
- (g_signal_connect adj "value_changed"
- (if (not use-log)
+ (let ((label-func (if (not use-log)
func
(lambda (w d)
(func w d)
(change-label label
(format #f "~A: ~,2F"
title
- (scale-linear->log low (gtk_adjustment_get_value (GTK_ADJUSTMENT adj)) high)))))
- #f)
+ (scale-linear->log low (gtk_adjustment_get_value (GTK_ADJUSTMENT adj)) high)))))))
+ (g_signal_connect adj "value_changed" label-func #f))
adj))
sliders)))
diff --git a/gtk-effects.scm b/gtk-effects.scm
index 07e8a53..0d66e95 100644
--- a/gtk-effects.scm
+++ b/gtk-effects.scm
@@ -100,9 +100,9 @@
(gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON button) on)
(gtk_widget_show button)
(g_signal_connect button "clicked" (lambda (w d) (target-callback type)) #f)))
- (list "entire sound" "selection" "between marks")
- (list 'sound 'selection 'marks)
- (list #t #f #f)))
+ '("entire sound" "selection" "between marks")
+ '(sound selection marks)
+ '(#t #f #f)))
(when truncate-callback
(let ((button (gtk_check_button_new_with_label "truncate at end")))
@@ -167,8 +167,7 @@
(define (scale-envelope e scl)
(if (null? e)
()
- (append (list (car e) (* scl (cadr e)))
- (scale-envelope (cddr e) scl))))
+ (cons (car e) (cons (* scl (cadr e)) (scale-envelope (cddr e) scl)))))
(gtk_menu_shell_append (GTK_MENU_SHELL amp-cascade) child)
(gtk_widget_show child)
@@ -183,7 +182,7 @@
(lambda (w data)
;; Gain scales amplitude by gain amount.
- (let ((with-env (and (not (equal? (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0)))
+ (let ((with-env (and (not (equal? (xe-envelope gain-envelope) '(0.0 1.0 1.0 1.0)))
(scale-envelope (xe-envelope gain-envelope) gain-amount))))
(if (eq? gain-target 'sound)
(if with-env
@@ -689,7 +688,7 @@ the modulation frequency, and the echo amplitude."))
;;;
(define* (effects-comb-filter scaler size beg dur snd chn)
- (let ((delay-line (make-float-vector size 0.0))
+ (let ((delay-line (make-float-vector size))
(delay-loc 0))
(lambda (x)
(let ((result (delay-line delay-loc)))
@@ -702,8 +701,8 @@ the modulation frequency, and the echo amplitude."))
(let ((documentation "(effects-comb-chord scaler size amp interval-one interval-two beg dur snd chn) is used by the effects dialog to tie into edit-list->function"))
(lambda* (scaler size amp interval-one interval-two beg dur snd chn)
(let ((cs (make-comb-bank (vector (make-comb scaler size)
- (make-comb scaler (* size interval-one))
- (make-comb scaler (* size interval-two))))))
+ (make-comb scaler (floor (* size interval-one)))
+ (make-comb scaler (floor (* size interval-two)))))))
(map-channel (lambda (x)
(* amp (comb-bank cs x)))
beg dur snd chn #f
@@ -1423,8 +1422,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(define (scale-envelope e scl)
(if (null? e)
()
- (append (list (car e) (* scl (cadr e)))
- (scale-envelope (cddr e) scl))))
+ (cons (car e) (cons (* scl (cadr e)) (scale-envelope (cddr e) scl)))))
(gtk_menu_shell_append (GTK_MENU_SHELL freq-cascade) child)
(gtk_widget_show child)
@@ -1449,8 +1447,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(let ((pts (plausible-mark-samples)))
(if pts
(let* ((beg (car pts))
- (end (cadr pts))
- (len (- end beg)))
+ (len (- (cadr pts) beg)))
(src-channel (make-env env :length len) beg len (selected-sound)))))))))
(lambda (w data)
@@ -1536,7 +1533,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(define am-effect
(lambda (freq)
(let* ((os (make-oscil freq))
- (need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (need-env (not (equal? (xe-envelope am-effect-envelope) '(0.0 1.0 1.0 1.0))))
(e (and need-env (make-env (xe-envelope am-effect-envelope) :length (effect-framples am-effect-target)))))
(if need-env
(lambda (inval)
@@ -1562,7 +1559,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
am-effect-target
(lambda (target samps)
(format #f "effects-am ~A ~A" am-effect-amount
- (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) '(0.0 1.0 1.0 1.0))))
(e (and need-env (xe-envelope am-effect-envelope))))
(and e (format #f "'~A" e)))))
#f))
@@ -1617,10 +1614,9 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(define rm-effect ; avoid collision with examp.scm
(lambda (freq gliss-env)
(let* ((os (make-oscil freq))
- (need-env (and rm-envelope (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0)))))
+ (need-env (and rm-envelope (not (equal? (xe-envelope rm-envelope) '(0.0 1.0 1.0 1.0)))))
(e (and need-env (make-env (xe-envelope rm-envelope) :length (effect-framples rm-target))))
- (len (framples))
- (genv (make-env :envelope gliss-env :length len)))
+ (genv (make-env :envelope gliss-env :length (framples))))
(if need-env
(lambda (inval)
(* inval (env e) (oscil os (env genv))))
@@ -1646,7 +1642,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
rm-target
(lambda (target samps)
(format #f "effects-rm ~A ~A" rm-frequency
- (let* ((need-env (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))))
+ (let* ((need-env (not (equal? (xe-envelope rm-envelope) '(0.0 1.0 1.0 1.0))))
(e (and need-env (xe-envelope rm-envelope))))
(and e (format #f "'~A" e)))))
#f))
@@ -2677,7 +2673,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
(do ((i 0 (+ i 1)))
((= i len))
(let ((inval (next-sample reader)))
- (set! lasty (+ inval (- (* 0.999 lasty) lastx)))
+ (set! lasty (- (+ inval (* 0.999 lasty)) lastx))
(set! lastx inval)
(float-vector-set! data i lasty))))
(float-vector->channel data 0 len snd chn current-edit-position "effects-remove-dc")))
diff --git a/jcrev.scm b/jcrev.scm
index cb00f32..fd406f9 100644
--- a/jcrev.scm
+++ b/jcrev.scm
@@ -14,11 +14,10 @@
(comb2 (make-comb 0.733 4999))
(comb3 (make-comb 0.715 5399))
(comb4 (make-comb 0.697 5801))
- (decay-dur *clm-srate*)
(chns (channels *output*))
(file-dur (framples *reverb*)))
- (let ((len (floor (+ decay-dur file-dur)))
+ (let ((len (floor (+ *clm-srate* file-dur)))
(filts (if (= chns 1)
(vector (make-delay (seconds->samples .013)))
(vector (make-delay (seconds->samples .013))
diff --git a/jcvoi.scm b/jcvoi.scm
index 2997d91..a823790 100644
--- a/jcvoi.scm
+++ b/jcvoi.scm
@@ -175,15 +175,8 @@
(let ((fmntfreq1 (round form1))
(fmntfreq2 (round form2))
(fmntfreq3 (round form3))
- (mfq (+ (* pitch mscale) mconst))
- (freqratios1 fm2)
- (freqratios2 mscale)
- (freqratios3 mscale)
- (freqratios4 mscale))
- (let ((freqratios5 fmntfreq1)
- (freqratios6 fmntfreq2)
- (freqratios7 fmntfreq3)
- (amp1 (sqrt amp))
+ (mfq (+ (* pitch mscale) mconst)))
+ (let ((amp1 (sqrt amp))
(amp2 (expt amp 1.5))
(amp3 (* amp amp))
(formscl1 (abs (- form1 fmntfreq1)))
@@ -242,20 +235,20 @@
(triangle-wave per-vib))
(* (env ranvenv)
(rand-interp ran-vib))))
- (cascadeout (* dev (oscil gens1 (* vib freqratios1)))))
+ (cascadeout (* dev (oscil gens1 (* vib fm2)))))
(locsig loc i (+ (* (env gens5ampenv)
- (oscil gens5 (+ (* vib freqratios5)
+ (oscil gens5 (+ (* vib fmntfreq1)
(* (env gens2ampenv)
- (oscil gens2 (+ cascadeout (* vib freqratios2)))))))
+ (oscil gens2 (+ cascadeout (* vib mscale)))))))
(* (env gens6ampenv)
- (oscil gens6 (+ (* vib freqratios6)
+ (oscil gens6 (+ (* vib fmntfreq2)
(* (env gens3ampenv)
- (oscil gens3 (+ cascadeout (* vib freqratios3)))))))
+ (oscil gens3 (+ cascadeout (* vib mscale)))))))
(* (env gens7ampenv)
- (oscil gens7 (+ (* vib freqratios7)
+ (oscil gens7 (+ (* vib fmntfreq3)
(* (env gens4ampenv)
- (oscil gens4 (+ cascadeout (* vib freqratios4))))))))))))))
- ))))
+ (oscil gens4 (+ cascadeout (* vib mscale))))))))))))))))))
+
#|
(let ((ampf '(0 0 1 1 2 1 3 0)))
(with-sound (:play #t) (fm-voice 0 1 300 .8 3 1 ampf ampf ampf ampf ampf ampf ampf 1 0 0 .25 .01 0 ampf .01)))
diff --git a/lint.scm b/lint.scm
index 743713b..2005d36 100644
--- a/lint.scm
+++ b/lint.scm
@@ -20,8 +20,12 @@
(define *report-doc-strings* #f) ; old-style (CL) doc strings
(define *report-func-as-arg-arity-mismatch* #f) ; as it says... (slow, and this error almost never happens)
(define *report-constant-expressions-in-do* #f) ; kinda dumb
-(define *report-bad-variable-names* '(l ll O)) ; bad names: '(l ll data datum new item info temp tmp val vals value foo bar baz aux dummy O var)
-(define *report-built-in-functions-used-as-variables* #f) ; string is the most common case
+(define *report-bad-variable-names* '(l ll O)) ; bad names -- a list to check such as:
+;;; '(l ll data datum new item info temp tmp val vals value foo bar baz aux dummy O var res retval result count str)
+(define *report-built-in-functions-used-as-variables* #f) ; string and length are the most common cases
+(define *report-forward-functions* #f) ; functions used before being defined
+(define *report-sloppy-assoc* #t) ; i.e. (cdr (assoc x y)) and the like
+(define *report-bloated-arg* 24) ; min arg expr tree size that can trigger a rewrite-as-let suggestion
(define *lint* #f) ; the lint let
;; this gives other programs a way to extend or edit lint's tables: for example, the
@@ -51,59 +55,11 @@
(error 'wrong-type-arg "let->list argument should be an environment: ~A" str))))
-(define *current-file* "")
-(define *lint-output-port* *stderr*)
-(define *top-level-objects* (make-hash-table))
-
(format *stderr* "loading lint.scm~%")
+
(set! reader-cond #f)
(define-macro (reader-cond . clauses) `(values)) ; clobber reader-cond to avoid (incorrect) unbound-variable errors
-(unless (provided? 'snd)
- (define definstrument define*)
- (define defgenerator define*))
-
-(define-macro (let*-temporarily vars . body)
- `(with-let (#_inlet :orig (#_curlet)
- :saved (#_list ,@(map car vars)))
- (dynamic-wind
- (lambda () #f)
- (lambda ()
- (with-let orig
- ,@(map (lambda (v)
- `(set! ,(car v) ,(cadr v)))
- vars)
- , at body))
- (lambda ()
- ,@(map (let ((ctr -1))
- (lambda (v)
- (if (symbol? (car v))
- `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
- `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
- vars)))))
-
-(define-macro (let-temporarily vars . body)
- `(with-let (#_inlet :orig (#_curlet)
- :saved (#_list ,@(map car vars))
- :new (#_list ,@(map cadr vars)))
- (dynamic-wind
- (lambda () #f)
- (lambda () ; this could be (with-let orig (let ,vars , at body)) but I want to handle stuff like individual vector locations
- ,@(map (let ((ctr -1))
- (lambda (v)
- (if (symbol? (car v))
- `(set! (orig ',(car v)) (list-ref new ,(set! ctr (+ ctr 1))))
- `(set! (with-let orig ,(car v)) (list-ref new ,(set! ctr (+ ctr 1)))))))
- vars)
- (with-let orig , at body))
- (lambda ()
- ,@(map (let ((ctr -1))
- (lambda (v)
- (if (symbol? (car v))
- `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
- `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
- vars)))))
-
#|
;; debugging version
(define-expansion (lint-format str caller . args)
@@ -226,6 +182,20 @@
char-position string-position pair-line-number port-line-number))
h))
+ (numeric-ops (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h op) #t))
+ '(+ * - /
+ sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh
+ log exp expt sqrt make-polar complex
+ imag-part real-part abs magnitude angle max min exact->inexact
+ modulo remainder quotient lcm gcd
+ rationalize inexact->exact random
+ logior lognot logxor logand numerator denominator
+ floor round truncate ceiling ash))
+ h))
+
(bools (let ((h (make-hash-table)))
(for-each
(lambda (op)
@@ -236,7 +206,7 @@
unspecified? c-object? constant?))
h))
- (bools1 (let ((h (make-hash-table)))
+ (booleans (let ((h (make-hash-table)))
(for-each
(lambda (op)
(set! (h op) #t))
@@ -277,6 +247,7 @@
(linted-files ())
(big-constants ())
(equable-closures ())
+ (other-names-counts (make-hash-table))
(*e* #f)
(other-identifiers #f)
(quote-warnings 0)
@@ -287,15 +258,59 @@
(last-checker-line-number -1)
(last-cons-line-number -1)
(last-rewritten-internal-define #f)
- (last-assoc-form #f)
(line-number -1)
(pp-left-margin 4)
- (lint-left-margin 1))
+ (lint-left-margin 1)
+ (*current-file* "")
+ (*top-level-objects* (make-hash-table))
+ (*output-port* *stderr*))
(set! *e* (curlet))
(set! *lint* *e*) ; external access to (for example) the built-in-functions hash-table via (*lint* 'built-in-functions)
+ (define-macro (let*-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (with-let orig
+ ,@(map (lambda (v)
+ `(set! ,(car v) ,(cadr v)))
+ vars)
+ , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
+
+ (define-macro (let-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars))
+ :new (#_list ,@(map cadr vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () ; this could be (with-let orig (let ,vars , at body)) but I want to handle stuff like individual vector locations
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref new ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref new ,(set! ctr (+ ctr 1)))))))
+ vars)
+ (with-let orig , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
+
+
;; -------- lint-format --------
(define target-line-length 80)
@@ -380,6 +395,7 @@
line-number
" ")))
(current-end (length outstr)))
+ ;; (set! made-suggestion (+ made-suggestion 1))
(display outstr outport)
(for-each (lambda (s)
(let ((len (length s)))
@@ -414,6 +430,7 @@
(define var-definer (dilambda (lambda (v) (let-ref (cdr v) 'definer)) (lambda (v x) (let-set! (cdr v) 'definer x))))
(define var-leaves (dilambda (lambda (v) (let-ref (cdr v) 'leaves)) (lambda (v x) (let-set! (cdr v) 'leaves x))))
(define var-scope (dilambda (lambda (v) (let-ref (cdr v) 'scope)) (lambda (v x) (let-set! (cdr v) 'scope x))))
+ (define var-setters (dilambda (lambda (v) (let-ref (cdr v) 'setters)) (lambda (v x) (let-set! (cdr v) 'setters x))))
(define var-env (dilambda (lambda (v) (let-ref (cdr v) 'env)) (lambda (v x) (let-set! (cdr v) 'env x))))
(define var-decl (dilambda (lambda (v) (let-ref (cdr v) 'decl)) (lambda (v x) (let-set! (cdr v) 'decl x))))
(define var-match-list (dilambda (lambda (v) (let-ref (cdr v) 'match-list)) (lambda (v x) (let-set! (cdr v) 'match-list x))))
@@ -443,6 +460,7 @@
(if initial-value (cons initial-value old) old))
(if initial-value (list initial-value) ()))
'scope ()
+ 'setters ()
'set 0
'ref (if old (length old) 0)))))
@@ -463,7 +481,7 @@
(define (remove-if p lst)
(cond ((null? lst) ())
((p (car lst)) (remove-if p (cdr lst)))
- (else (cons (car lst)
+ (else (cons (car lst)
(remove-if p (cdr lst))))))
(define (lint-remove-duplicates lst env)
@@ -479,7 +497,8 @@
(define applicable? arity)
(define every?
- (let ((documentation "(every? func sequence) returns #t if func approves of every member of sequence"))
+ (let ((documentation "(every? func sequence) returns #t if func approves of every member of sequence")
+ (signature '(boolean? procedure? sequence?)))
(lambda (f sequence)
(call-with-exit
(lambda (return)
@@ -487,7 +506,8 @@
#t)))))
(define any?
- (let ((documentation "(any? func sequence) returns #t if func approves of any member of sequence"))
+ (let ((documentation "(any? func sequence) returns #t if func approves of any member of sequence")
+ (signature '(boolean? procedure? sequence?)))
(lambda (f sequence)
(call-with-exit
(lambda (return)
@@ -686,6 +706,17 @@
(eq? (car x) 'quote)
(pair? (cdr x))
(null? (cadr x))))
+
+ (define (any-null? x)
+ (or (null? x)
+ (and (pair? x)
+ (case (car x)
+ ((quote)
+ (and (pair? (cdr x))
+ (null? (cadr x))))
+ ((list)
+ (null? (cdr x)))
+ (else #f)))))
(define (quoted-not? x)
(and (pair? x)
@@ -835,8 +866,7 @@
(if (pair? m)
(let ((fsig (arg-signature f env)))
(if (pair? fsig)
- (let* ((loc (- (length p) (length m)))
- (chk (catch #t (lambda () (fsig loc)) (lambda args #f))))
+ (let ((chk (catch #t (lambda () (fsig (- (length p) (length m)))) (lambda args #f))))
(if (and (symbol? chk) ; it defaults to #t
(not (memq chk '(integer:any? integer:real?))))
(set-car! sig chk)))))))))))
@@ -892,8 +922,8 @@
(pair? (cdr v)))
(var-walk (cadr v) e)
(set! vars (cons (shadowed (car v)) vars))))
- (if named (caddr tree) (cadr tree)))
- (var-walk-body (if named (cdddr tree) (cddr tree)) (append vars e)))))
+ ((if named caddr cadr) tree))
+ (var-walk-body ((if named cdddr cddr) tree) (append vars e)))))
((case)
(when (and (pair? (cdr tree))
@@ -912,8 +942,8 @@
(pair? (cdr v)))
(var-walk (cadr v) (append vars e))
(set! vars (cons (shadowed (car v)) vars))))
- (if named (caddr tree) (cadr tree)))
- (var-walk-body (if named (cdddr tree) (cddr tree)) (append vars e))))
+ ((if named caddr cadr) tree))
+ (var-walk-body ((if named cdddr cddr) tree) (append vars e))))
((do)
(let ((vars ()))
@@ -971,6 +1001,11 @@
(side-effect-with-vars? f env outvars))
body))))))
+ (define (last-par x)
+ (let ((len (length x)))
+ (and (positive? len)
+ (x (- len 1)))))
+
(define* (make-fvar name ftype arglist decl initial-value env)
(let* ((old (hash-table-ref other-identifiers name))
(new (cons name
@@ -980,6 +1015,7 @@
(memq ftype '(define* define-macro* define-bacro* defmacro*))
(eq? (last-par arglist) :allow-other-keys))
'scope ()
+ 'setters ()
'env env
'initial-value initial-value
'values (and (pair? initial-value) (count-values (cddr initial-value)))
@@ -1011,7 +1047,7 @@
(car sig))))) ; this might be undefined in the current context (eg oscil? outside clm)
(define (any-macro? f env)
- (or (memq f '(call-with-values let-values define-values let*-values cond-expand require quasiquote multiple-value-bind reader-cond))
+ (or (memq f '(call-with-values let-values define-values let*-values cond-expand require quasiquote multiple-value-bind reader-cond match while))
(let ((fd (var-member f env)))
(and (var? fd)
(memq (var-ftype fd) '(define-macro define-macro* define-expansion define-bacro define-bacro* defmacro defmacro* define-syntax))))))
@@ -1026,17 +1062,17 @@
((rational? c) 'rational?)
((real? c) 'real?)
((number? c) 'number?)
- ((keyword? c)
- (cond ((assq c markers) => cdr)
- (else 'keyword?)))
- ((byte-vector? c) 'byte-vector?)
((string? c) 'string?)
((null? c) 'null?)
((char? c) 'char?)
((boolean? c) 'boolean?)
+ ((keyword? c)
+ (cond ((assq c markers) => cdr)
+ (else 'keyword?)))
+ ((vector? c) 'vector?)
((float-vector? c) 'float-vector?)
((int-vector? c) 'int-vector?)
- ((vector? c) 'vector?)
+ ((byte-vector? c) 'byte-vector?)
((let? c) 'let?)
((hash-table? c) 'hash-table?)
((input-port? c) 'input-port?)
@@ -1051,7 +1087,7 @@
((c-object? c) 'c-object?)
((eof-object? c) 'eof-object?)
((syntax? c) 'syntax?)
- ((eq? c #<unspecified>) 'unspecified?)
+ ((assq c '((#<unspecified> . unspecified?) (#<undefined> . undefined?))) => cdr)
(#t #t)))))
(define (define->type c)
@@ -1080,8 +1116,8 @@
(or (eq? type1 type2)
(not (symbol? type1))
(not (symbol? type2))
- (not (hash-table-ref bools1 type1))
- (not (hash-table-ref bools1 type2))
+ (not (hash-table-ref booleans type1))
+ (not (hash-table-ref booleans type2))
(case type1
((number? complex?) (memq type2 '(float? real? rational? integer? number? complex? exact? inexact? zero? negative? positive? even? odd? infinite? nan?)))
((real?) (memq type2 '(float? rational? integer? complex? number? exact? inexact? zero? negative? positive? even? odd? infinite? nan?)))
@@ -1165,6 +1201,32 @@
(pair? (cdr expr))
(never-false (cadr expr)))))
+ (define (prettify-checker-unq op)
+ (if (pair? op)
+ (string-append (prettify-checker-unq (car op)) " or " (prettify-checker-unq (cadr op)))
+ (case op
+ ((rational?) "rational")
+ ((real?) "real")
+ ((complex?) "complex")
+ ((null?) "null")
+ ((length) "a sequence")
+ ((unspecified?) "untyped")
+ ((undefined?) "not defined")
+ (else
+ (let ((op-name (symbol->string op)))
+ (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ")
+ (substring op-name 0 (- (length op-name) 1))))))))
+
+ (define (prettify-checker op)
+ (if (pair? op)
+ (string-append (prettify-checker-unq (car op)) " or " (prettify-checker (cadr op)))
+ (let ((op-name (symbol->string op)))
+ (case op
+ ((rational? real? complex? null?) op-name)
+ ((unspecified?) "untyped")
+ ((undefined?) "not defined")
+ (else (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ") op-name))))))
+
(define (side-effect-with-vars? form env vars)
;; could evaluation of form have any side effects (like IO etc)
@@ -1172,12 +1234,13 @@
(null? form))
(and (symbol? form)
- (let ((e (var-member form env)))
- (if (var? e)
- (and (symbol? (var-ftype e))
- (var-side-effect e))
- (and (not (hash-table-ref no-side-effect-functions form))
- (procedure? (symbol->value form *e*))))))
+ (or (eq? form '=>)
+ (let ((e (var-member form env)))
+ (if (var? e)
+ (and (symbol? (var-ftype e))
+ (var-side-effect e))
+ (and (not (hash-table-ref no-side-effect-functions form))
+ (procedure? (symbol->value form *e*)))))))
;; can't optimize ((...)...) because the car might eval to a function
(or (and (not (hash-table-ref no-side-effect-functions (car form)))
@@ -1306,6 +1369,7 @@
(constant? form)
(and (symbol? (car form))
(hash-table-ref no-side-effect-functions (car form))
+ (hash-table-ref built-in-functions (car form)) ; and not hook-functions
(not (var-member (car form) env)) ; e.g. exp declared locally as a list
(every? (lambda (p) (just-constants? p env)) (cdr form)))))
@@ -1350,7 +1414,10 @@
(set! (var-ref data) (+ (var-ref data) 1))
(update-scope data caller env)
(if (and form (not (memq form (var-history data))))
- (set! (var-history data) (cons form (var-history data)))))))
+ (set! (var-history data) (cons form (var-history data)))))
+ (if (not (defined? name (rootlet)))
+ (let ((old (hash-table-ref other-identifiers name)))
+ (hash-table-set! other-identifiers name (if old (cons form old) (list form)))))))
env)
@@ -1359,6 +1426,8 @@
(when (var? data)
(set! (var-set data) (+ (var-set data) 1))
(update-scope data caller env)
+ (if (not (memq caller (var-setters data)))
+ (set! (var-setters data) (cons caller (var-setters data))))
(if (not (memq form (var-history data)))
(set! (var-history data) (cons form (var-history data))))
(set! (var-signature data) #f)
@@ -1385,32 +1454,31 @@
;(count-if keyword? lst))
(define (eqv-selector clause)
- (if (pair? clause)
+ (if (not (pair? clause))
+ (memq clause '(else #t))
(case (car clause)
((memq memv member)
(and (= (length clause) 3)
(cadr clause)))
((eq? eqv? = equal? char=? char-ci=? string=? string-ci=?)
(and (= (length clause) 3)
- (if (code-constant? (cadr clause))
- (caddr clause)
- (cadr clause))))
+ ((if (code-constant? (cadr clause)) caddr cadr) clause)))
((or)
(and (pair? (cdr clause))
(eqv-selector (cadr clause))))
((not null? eof-object? zero? boolean?)
(and (pair? (cdr clause))
(cadr clause)))
- (else #f))
- (memq clause '(else #t))))
+ (else #f))))
(define (->eqf x)
(case x
((char?) '(eqv? char=?))
((integer? rational? real? number? complex?) '(eqv? =))
- ((symbol? keyword? boolean? null? procedure? syntax? macro?)'(eq? eq?))
+ ((symbol? keyword? boolean? null? procedure? syntax? macro? undefined? unspecified?) '(eq? eq?))
((string? byte-vector?) '(equal? string=?))
((pair? vector? float-vector? int-vector? hash-table?) '(equal? equal?))
+ ((eof-object?) '(eq? eof-object?))
(else
(if (and (pair? x)
(pair? (cdr x))
@@ -1424,15 +1492,15 @@
(define (eqf selector env)
(cond ((symbol? selector)
-
(if (and (not (var-member selector env))
(or (hash-table-ref built-in-functions selector)
(hash-table-ref syntaces selector)))
'(eq? eq?)
- '(#t #t))
- )
+ '(#t #t)))
+
+ ((not (pair? selector))
+ (->eqf (->lint-type selector)))
- ((not (pair? selector)) (->eqf (->lint-type selector)))
((eq? (car selector) 'quote)
(cond ((or (symbol? (cadr selector))
(memq (cadr selector) '(#f #t #<unspecified> #<undefined> #<eof> ())))
@@ -1441,14 +1509,17 @@
((string? (cadr selector)) '(equal? string=?))
((number? (cadr selector)) '(eqv? =))
(else '(equal? equal?))))
+
((and (eq? (car selector) 'list)
(null? (cdr selector)))
'(eq? eq?))
+
((symbol? (car selector))
(let ((sig (arg-signature (car selector) env)))
(if (pair? sig)
(->eqf (car sig))
'(#t #t))))
+
(else '(#t #t))))
(define (unquoted x)
@@ -1518,196 +1589,60 @@
(or (eq? type ret)
(and (pair? ret)
(memq type ret))))
-
-
- (define relsub
- (let ((relops '((< <= > number?) (<= < >= number?) (> >= < number?) (>= > <= number?)
- (char<? char<=? char>? char?) (char<=? char<? char>=? char?) ; these never happen
- (char>? char>=? char<? char?) (char>=? char>? char<=? char?)
- (string<? string<=? string>? string?) (string<=? string<? string>=? string?)
- (string>? string>=? string<? string?) (string>=? string>? string<=? string?))))
- (lambda (A B rel-op env)
- (call-with-exit
- (lambda (return)
- (when (and (pair? A)
- (pair? B)
- (= (length A) (length B) 3))
- (let ((Adata (assq (car A) relops))
- (Bdata (assq (car B) relops)))
- (when (and Adata Bdata)
- (let ((op1 (car A))
- (op2 (car B))
- (A1 (cadr A))
- (A2 (caddr A))
- (B1 (cadr B))
- (B2 (caddr B)))
- (let ((x (if (and (not (number? A1))
- (member A1 B))
- A1
- (and (not (number? A2))
- (member A2 B)
- A2))))
- (when x
- (let ((c1 (if (eq? x A1) A2 A1))
- (c2 (if (eq? x B1) B2 B1))
- (type (cadddr Adata)))
- (if (or (side-effect? c1 env)
- (side-effect? c2 env)
- (side-effect? x env))
- (return 'ok))
- (if (eq? x A2) (set! op1 (caddr Adata)))
- (if (eq? x B2) (set! op2 (caddr Bdata)))
-
- (let ((typer #f)
- (gtes #f)
- (gts #f)
- (eqop #f))
- (case type
- ((number?)
- (set! typer number?)
- (set! gtes '(>= <=))
- (set! gts '(< >))
- (set! eqop '=))
- ((char?)
- (set! typer char?)
- (set! gtes '(char>=? char<=?))
- (set! gts '(char<? char>?))
- (set! eqop 'char=?))
- ((string?)
- (set! typer string?)
- (set! gtes '(string>=? string<=?))
- (set! gts '(string<? string>?))
- (set! eqop 'string=?)))
-
- (case rel-op
- ((and)
- (cond ((equal? c1 c2)
- (cond ((eq? op1 op2)
- (return `(,op1 ,x ,c1)))
-
- ((eq? op2 (cadr (assq op1 relops)))
- (if (memq op2 gtes)
- (return `(,op1 ,x ,c1))
- (return `(,op2 ,x ,c1))))
-
- ((and (memq op1 gtes)
- (memq op2 gtes))
- (return `(,eqop ,x ,c1)))
-
- (else (return #f))))
-
- ((and (typer c1)
- (typer c2))
- (cond ((or (eq? op1 op2)
- (eq? op2 (cadr (assq op1 relops))))
- (if ((symbol->value op1) c1 c2)
- (return `(,op1 ,x ,c1))
- (return `(,op2 ,x ,c2))))
- ((eq? op1 (caddr (assq op2 relops)))
- (if ((symbol->value op1) c2 c1)
- (return `(,op1 ,c2 ,x ,c1))
- (if (memq op1 gts)
- (return #f))))
- ((and (eq? op2 (hash-table-ref reversibles (cadr (assq op1 relops))))
- ((symbol->value op1) c1 c2))
- (return #f))))))
-
- ((or)
- (cond ((equal? c1 c2)
- (cond ((eq? op1 op2)
- (return `(,op1 ,x ,c1)))
-
- ((eq? op2 (cadr (assq op1 relops)))
- (if (memq op2 gtes)
- (return `(,op2 ,x ,c1))
- (return `(,op1 ,x ,c1))))
-
- ((and (memq op1 gts)
- (memq op2 gts))
- (return `(not (,eqop ,x ,c1))))
-
- (else (return #t))))
-
- ((and (typer c1)
- (typer c2))
- (cond ((or (eq? op1 op2)
- (eq? op2 (cadr (assq op1 relops))))
- (if ((symbol->value op1) c1 c2)
- (return `(,op2 ,x ,c2))
- (return `(,op1 ,x ,c1))))
- ((eq? op1 (caddr (assq op2 relops)))
- (if ((symbol->value op1) c2 c1)
- (return #t))
- (return `(not (,(cadr (assq op1 relops)) ,c1 ,x ,c2))))
- ((and (eq? op2 (hash-table-ref reversibles (cadr (assq op1 relops))))
- ((symbol->value op1) c2 c1))
- (return #t)))))))))))))))
- 'ok)))))
+
+ (define last-and-incomplete-arg2 #f)
+
+ (define (and-incomplete form head arg1 arg2 env) ; head: 'and | 'or (not ...) | 'if | 'if2 -- symbol arg1 in any case
+ (unless (memq (car arg2) '(and or not list cons vector)) ; these don't tell us anything about arg1's type
+ (let ((v (var-member arg1 env))) ; try to avoid the member->cdr trope
+ (unless (or (eq? arg2 last-and-incomplete-arg2)
+ (and (var? v)
+ (pair? (var-history v))
+ (member #f (var-history v)
+ (lambda (a b)
+ (and (pair? b)
+ (memq (car b) '(char-position string-position format string->number assoc assq assv memq memv member)))))))
+ (let* ((pos (do ((i 0 (+ i 1)) ; get arg number of arg1 in arg2
+ (p arg2 (cdr p))) ; 0th=car -> (and x (x))
+ ((or (null? p)
+ (eq? (car p) arg1))
+ i)))
+ (sig (and (positive? pos) ; procedure-signature for arg2
+ (arg-signature (car arg2) env)))
+ (arg-type (if (zero? pos) ; it's type indication for arg1's position
+ 'procedure? ; or sequence? -- how to distinguish? use 'applicable?
+ (and (pair? sig)
+ (< pos (length sig))
+ (list-ref sig pos))))
+ (ln (and (< 0 line-number 100000) line-number))
+ (comment (if (and (eq? arg-type 'procedure?)
+ (= pos 0)
+ (pair? (cdr arg2)))
+ " ; or maybe sequence? " "")))
+
+ (set! last-and-incomplete-arg2 arg2) ; ignore unwanted repetitions due to recursive simplifications
+ (if (symbol? arg-type)
+ (let ((old-arg (case head
+ ((and if cond when) arg1)
+ ((or if2) `(not ,arg1))))
+ (new-arg (case head
+ ((and if cond when) `(,arg-type ,arg1))
+ ((or if2) `(not (,arg-type ,arg1))))))
+ (format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~A~%"
+ lint-left-margin #\space
+ (truncated-list->string form)
+ (if ln (format #f " (line ~D)" ln) "")
+ (+ lint-left-margin 4) #\space
+ old-arg new-arg comment))))))))
- (define simplify-boolean
- (let ((notables (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h (car op)) (cadr op)))
- '((< >=) (> <=) (<= >) (>= <)
- (char<? char>=?) (char>? char<=?) (char<=? char>?) (char>=? char<?)
- (string<? string>=?) (string>? string<=?) (string<=? string>?) (string>=? string<?)
- (char-ci<? char-ci>=?) (char-ci>? char-ci<=?) (char-ci<=? char-ci>?) (char-ci>=? char-ci<?)
- (string-ci<? string-ci>=?) (string-ci>? string-ci<=?) (string-ci<=? string-ci>?) (string-ci>=? string-ci<?)
- (odd? even?) (even? odd?) (exact? inexact?) (inexact? exact?)))
- h)))
- (lambda (in-form true false env)
-
- (define (classify e)
- (if (not (just-constants? e env))
- e
- (catch #t
- (lambda ()
- (let ((val (eval e)))
- (if (boolean? val)
- val
- e)))
- (lambda ignore e))))
-
- (define (contradictory? ands)
- (let ((vars ()))
- (call-with-exit
- (lambda (return)
- (do ((b ands (cdr b)))
- ((null? b) #f)
- (if (and (pair? b)
- (pair? (car b))
- (pair? (cdar b)))
- (let ((func (caar b))
- (args (cdar b)))
-
- (if (memq func '(eq? eqv? equal?))
- (if (and (symbol? (car args))
- (code-constant? (cadr args)))
- (set! func (->lint-type (cadr args)))
- (if (and (symbol? (cadr args))
- (code-constant? (car args)))
- (set! func (->lint-type (car args))))))
-
- (if (symbol? func)
- (for-each
- (lambda (arg)
- (if (symbol? arg)
- (let ((type (assq arg vars)))
- (if (not type)
- (set! vars (cons (cons arg func) vars))
- (if (not (compatible? (cdr type) func))
- (return #t))))))
- args)))))))))
-
(define (and-redundant? arg1 arg2)
(let ((type1 (car arg1))
(type2 (car arg2)))
(and (symbol? type1)
(symbol? type2)
- (hash-table-ref bools1 type1)
- (or (hash-table-ref bools1 type2) ; return #f if not (obviously) redundant, else return which of the two to keep
+ (hash-table-ref booleans type1)
+ (or (hash-table-ref booleans type2) ; return #f if not (obviously) redundant, else return which of the two to keep
(memq type2 '(= char=? string=? not eq?)))
(if (eq? type1 type2)
type1
@@ -1716,9 +1651,7 @@
(case type2
((float? real? rational? integer?) type2)
((number? complex?) type1)
- ((=) (let ((x (if (number? (caddr arg2))
- (caddr arg2)
- (cadr arg2))))
+ ((=) (let ((x ((if (number? (caddr arg2)) caddr cadr) arg2)))
(and (number? x)
(if (= x (floor x)) 'memv 'eqv?))))
(else #f)))
@@ -1727,9 +1660,7 @@
(case type2
((float? rational? integer?) type2)
((number? complex?) type1)
- ((=) (let ((x (if (real? (caddr arg2))
- (caddr arg2)
- (cadr arg2))))
+ ((=) (let ((x ((if (real? (caddr arg2)) caddr cadr) arg2)))
(and (real? x)
(if (= x (floor x)) 'memv 'eqv?))))
(else #f)))
@@ -1844,6 +1775,273 @@
(else #f))))))
+ (define (and-forgetful form head arg1 arg2 env)
+ (unless (or (memq (car arg2) '(and or not list cons vector)) ; these don't tell us anything about arg1's type
+ (eq? arg2 last-and-incomplete-arg2))
+ (let* ((pos (do ((i 0 (+ i 1)) ; get arg number of arg1 in arg2
+ (p arg2 (cdr p))) ; 0th=car -> (and x (x))
+ ((or (null? p)
+ (equal? (car p) (cadr arg1)))
+ (if (null? p) -1 i))))
+ (sig (and (positive? pos) ; procedure-signature for arg2
+ (arg-signature (car arg2) env)))
+ (arg-type (if (zero? pos) ; its type indication for arg1's position
+ 'procedure? ; or sequence? -- how to distinguish? use 'applicable?
+ (and (pair? sig)
+ (< pos (length sig))
+ (list-ref sig pos)))))
+ (when (symbol? arg-type)
+ (let ((new-type (and-redundant? arg1 (cons arg-type (cadr arg1)))))
+ (when (and new-type
+ (not (eq? new-type (car arg1))))
+ (let ((old-arg (case head
+ ((and if cond when) arg1)
+ ((or if2) `(not ,arg1))))
+ (new-arg (case head
+ ((and if cond when) `(,new-type ,(cadr arg1)))
+ ((or if2) `(not (,new-type ,(cadr arg1))))))
+ (ln (and (< 0 line-number 100000) line-number))
+ (comment (if (and (eq? arg-type 'procedure?)
+ (= pos 0)
+ (pair? (cdr arg2)))
+ " ; or maybe sequence? " "")))
+ (set! last-and-incomplete-arg2 arg2)
+ (format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~A~%"
+ lint-left-margin #\space
+ (truncated-list->string form)
+ (if ln (format #f " (line ~D)" ln) "")
+ (+ lint-left-margin 4) #\space
+ old-arg new-arg comment)))))))
+
+ ;; perhaps change pair? -> eq? or ignore it?
+ (when (and (pair? (cdr arg2))
+ (not (eq? (car arg1) 'pair?)))
+ (let ((a2 (if (eq? (car arg2) 'not)
+ (cadr arg2)
+ arg2)))
+ (when (and (pair? a2)
+ (memq (car a2) '(memq memv member assq assv assoc eq? eqv? equal?))
+ (equal? (cadr arg1) (cadr a2)))
+ (let ((new-e (case (car (->eqf (car arg1)))
+ ((eq?)
+ (case (car a2)
+ ((memq assq eq?) (car a2))
+ ((memv member) 'memq)
+ ((assv assoc) 'assq)
+ ((eqv? equal?) 'eq?)))
+ ((eqv?)
+ (case (car a2)
+ ((memv assv eqv?) (car a2))
+ ((memq member) 'memv)
+ ((assq assoc) 'assv)
+ ((eq? equal?) 'eqv?)))
+ ((equal?)
+ (case (car a2)
+ ((member assoc equal?) (car a2))
+ ((memq memv) 'member)
+ ((assq assv) 'assoc)
+ ((eq? eqv?) 'equal?)))
+ (else (car a2)))))
+ (when (and (not (eq? (car a2) new-e))
+ (symbol? new-e))
+ (let ((ln (and (< 0 line-number 100000) line-number)))
+ (format outport "~NCin ~A~A,~%~NCperhaps change ~A to ~A~%"
+ lint-left-margin #\space
+ (truncated-list->string form)
+ (if ln (format #f " (line ~D)" ln) "")
+ (+ lint-left-margin 4) #\space
+ (truncated-list->string a2)
+ `(,new-e ...)))))))))
+
+
+ ;; --------------------------------
+ (define simplify-boolean
+
+ (let ((notables (let ((h (make-hash-table)))
+ (for-each
+ (lambda (op)
+ (set! (h (car op)) (cadr op)))
+ '((< >=) (> <=) (<= >) (>= <)
+ (char<? char>=?) (char>? char<=?) (char<=? char>?) (char>=? char<?)
+ (string<? string>=?) (string>? string<=?) (string<=? string>?) (string>=? string<?)
+ (char-ci<? char-ci>=?) (char-ci>? char-ci<=?) (char-ci<=? char-ci>?) (char-ci>=? char-ci<?)
+ (string-ci<? string-ci>=?) (string-ci>? string-ci<=?) (string-ci<=? string-ci>?) (string-ci>=? string-ci<?)
+ (odd? even?) (even? odd?) (exact? inexact?) (inexact? exact?)))
+ h))
+ (relsub
+ (let ((relops '((< <= > number?) (<= < >= number?) (> >= < number?) (>= > <= number?)
+ (char<? char<=? char>? char?) (char<=? char<? char>=? char?) ; these never happen
+ (char>? char>=? char<? char?) (char>=? char>? char<=? char?)
+ (string<? string<=? string>? string?) (string<=? string<? string>=? string?)
+ (string>? string>=? string<? string?) (string>=? string>? string<=? string?))))
+ (lambda (A B rel-op env)
+ (call-with-exit
+ (lambda (return)
+ (when (and (pair? A)
+ (pair? B)
+ (= (length A) (length B) 3))
+ (let ((Adata (assq (car A) relops))
+ (Bdata (assq (car B) relops)))
+ (when (and Adata Bdata)
+ (let ((op1 (car A))
+ (op2 (car B))
+ (A1 (cadr A))
+ (A2 (caddr A))
+ (B1 (cadr B))
+ (B2 (caddr B)))
+ (let ((x (if (and (not (number? A1))
+ (member A1 B))
+ A1
+ (and (not (number? A2))
+ (member A2 B)
+ A2))))
+ (when x
+ (let ((c1 (if (equal? x A1) A2 A1))
+ (c2 (if (equal? x B1) B2 B1))
+ (type (cadddr Adata)))
+ (if (or (side-effect? c1 env)
+ (side-effect? c2 env)
+ (side-effect? x env))
+ (return 'ok))
+ (if (equal? x A2) (set! op1 (caddr Adata)))
+ (if (equal? x B2) (set! op2 (caddr Bdata)))
+
+ (let ((typer #f)
+ (gtes #f)
+ (gts #f)
+ (eqop #f))
+ (case type
+ ((number?)
+ (set! typer number?)
+ (set! gtes '(>= <=))
+ (set! gts '(< >))
+ (set! eqop '=))
+ ((char?)
+ (set! typer char?)
+ (set! gtes '(char>=? char<=?))
+ (set! gts '(char<? char>?))
+ (set! eqop 'char=?))
+ ((string?)
+ (set! typer string?)
+ (set! gtes '(string>=? string<=?))
+ (set! gts '(string<? string>?))
+ (set! eqop 'string=?)))
+
+ (case rel-op
+ ((and)
+ (cond ((equal? c1 c2)
+ (cond ((eq? op1 op2)
+ (return `(,op1 ,x ,c1)))
+
+ ((eq? op2 (cadr (assq op1 relops)))
+ (if (memq op2 gtes)
+ (return `(,op1 ,x ,c1))
+ (return `(,op2 ,x ,c1))))
+
+ ((and (memq op1 gtes)
+ (memq op2 gtes))
+ (return `(,eqop ,x ,c1)))
+
+ (else (return #f))))
+
+ ((and (typer c1)
+ (typer c2))
+ (cond ((or (eq? op1 op2)
+ (eq? op2 (cadr (assq op1 relops))))
+ (if ((symbol->value op1) c1 c2)
+ (return `(,op1 ,x ,c1))
+ (return `(,op2 ,x ,c2))))
+ ((eq? op1 (caddr (assq op2 relops)))
+ (if ((symbol->value op1) c2 c1)
+ (return `(,op1 ,c2 ,x ,c1))
+ (if (memq op1 gts)
+ (return #f))))
+ ((and (eq? op2 (hash-table-ref reversibles (cadr (assq op1 relops))))
+ ((symbol->value op1) c1 c2))
+ (return #f))))
+
+ ((eq? op2 (caddr (assq op1 relops)))
+ (return `(,op1 ,c2 ,x ,c1)))))
+
+ ((or)
+ (cond ((equal? c1 c2)
+ (cond ((eq? op1 op2)
+ (return `(,op1 ,x ,c1)))
+
+ ((eq? op2 (cadr (assq op1 relops)))
+ (if (memq op2 gtes)
+ (return `(,op2 ,x ,c1))
+ (return `(,op1 ,x ,c1))))
+
+ ((and (memq op1 gts)
+ (memq op2 gts))
+ (return `(not (,eqop ,x ,c1))))
+
+ (else (return #t))))
+
+ ((and (typer c1)
+ (typer c2))
+ (cond ((or (eq? op1 op2)
+ (eq? op2 (cadr (assq op1 relops))))
+ (if ((symbol->value op1) c1 c2)
+ (return `(,op2 ,x ,c2))
+ (return `(,op1 ,x ,c1))))
+ ((eq? op1 (caddr (assq op2 relops)))
+ (if ((symbol->value op1) c2 c1)
+ (return #t))
+ (return `(not (,(cadr (assq op1 relops)) ,c1 ,x ,c2))))
+ ((and (eq? op2 (hash-table-ref reversibles (cadr (assq op1 relops))))
+ ((symbol->value op1) c2 c1))
+ (return #t))))
+
+ ((eq? op2 (caddr (assq op1 relops)))
+ (return `(not (,(cadr (assq op1 relops)) ,c1 ,x ,c2)))))))))))))))
+ 'ok))))))
+
+ (lambda (in-form true false env)
+
+ (define (classify e)
+ (if (not (just-constants? e env))
+ e
+ (catch #t
+ (lambda ()
+ (let ((val (eval e)))
+ (if (boolean? val)
+ val
+ e)))
+ (lambda ignore e))))
+
+ (define (contradictory? ands)
+ (let ((vars ()))
+ (call-with-exit
+ (lambda (return)
+ (do ((b ands (cdr b)))
+ ((null? b) #f)
+ (if (and (pair? b)
+ (pair? (car b))
+ (pair? (cdar b)))
+ (let ((func (caar b))
+ (args (cdar b)))
+
+ (if (memq func '(eq? eqv? equal?))
+ (if (and (symbol? (car args))
+ (code-constant? (cadr args)))
+ (set! func (->lint-type (cadr args)))
+ (if (and (symbol? (cadr args))
+ (code-constant? (car args)))
+ (set! func (->lint-type (car args))))))
+
+ (if (symbol? func)
+ (for-each
+ (lambda (arg)
+ (if (symbol? arg)
+ (let ((type (assq arg vars)))
+ (if (not type)
+ (set! vars (cons (cons arg func) vars))
+ (if (not (compatible? (cdr type) func))
+ (return #t))))))
+ args)))))))))
+
(define (and-redundants env . args)
(let ((locals ())
(diffs #f))
@@ -1851,7 +2049,7 @@
((or (null? p)
(not (and (pair? (car p))
(pair? (cdar p))
- (hash-table-ref bools1 (caar p)))))
+ (hash-table-ref booleans (caar p)))))
(and (null? p)
(pair? locals)
(or diffs
@@ -1865,7 +2063,7 @@
(let ((res (apply and-redundant? (reverse (cdr a)))))
(if res
(begin
- (set! keepers (cons (if (eq? res (caadr a)) (cadr a) (caddr a)) keepers))
+ (set! keepers (cons ((if (eq? res (caadr a)) cadr caddr) a) keepers))
(set! diffs #t))
(set! keepers (cons (cadr a) (cons (caddr a) keepers))))))
@@ -1912,9 +2110,9 @@
(type2 (caadr arg2))) ; (not (? ...))
(and (symbol? type1)
(symbol? type2)
- (or (hash-table-ref bools1 type1)
+ (or (hash-table-ref booleans type1)
(memq type1 '(= char=? string=?)))
- (hash-table-ref bools1 type2)
+ (hash-table-ref booleans type2)
(if (eq? type1 type2) ; (and (?) (not (?))) -> #f
'contradictory
(case type1
@@ -2043,7 +2241,7 @@
((string?)
(and (not (eq? type2 'byte-vector?)) arg2))
(else #f))))))
-
+
(define (bsimp x) ; quick check for common easy cases
(set! last-simplify-boolean-line-number line-number)
(if (not (and (pair? x)
@@ -2175,26 +2373,46 @@
(else
`(,func ,sym ',(reverse elements) , at equals)))))
+ (define (reversible-member expr lst)
+ (and (pair? lst)
+ (or (member expr lst)
+ (and (eqv? (length expr) 3)
+ (let ((rev-op (hash-table-ref reversibles (car expr))))
+ (and rev-op
+ (member (list rev-op (caddr expr) (cadr expr)) lst)))))))
+
+ (define and-rel-ops (let ((h (make-hash-table)))
+ (for-each (lambda (op)
+ (hash-table-set! h op #t))
+ '(< = > <= >= char-ci>=? char-ci<? char-ready? char<? char-ci=? char>?
+ char<=? char-ci>? char-ci<=? char>=? char=? string-ci<=? string=?
+ string-ci>=? string<? string-ci<? string-ci=? string-ci>? string>=? string<=? string>?
+ eqv? equal? eq? morally-equal?))
+ h))
+ ;; --------------------------------
;; start of simplify-boolean code
;; this is not really simplify boolean as in boolean algebra because in scheme there are many unequal truths, but only one falsehood
;; 'and and 'or are not boolean operators in a sense
+
+ ;; (format *stderr* "simplify: ~A~%" in-form)
- (and (not (or (member in-form false)
+ (and (not (or (reversible-member in-form false)
(and (pair? in-form)
(eq? (car in-form) 'not)
(pair? (cdr in-form)) ; (not)!
- (member (cadr in-form) true))))
- (or (and (member in-form true) #t)
+ (reversible-member (cadr in-form) true))))
+ (or (and (reversible-member in-form true) #t)
(and (pair? in-form)
(eq? (car in-form) 'not)
(pair? (cdr in-form))
- (member (cadr in-form) false)
+ (reversible-member (cadr in-form) false)
#t)
(if (not (pair? in-form))
in-form
(let ((form (bcomp (bsimp in-form))))
+
(if (not (and (pair? form)
(memq (car form) '(or and not))))
(classify form)
@@ -2231,7 +2449,7 @@
;; (or (and A B) (and C B)) -> (and (or A C) B)
;; (and (or A B) (or A C)) -> (or A (and B C))
;; (and (or A B) (or C B)) -> (or (and A C) B)
-
+
(case (car form)
;; --------------------------------
((not)
@@ -2259,8 +2477,8 @@
#f)
((and (pair? arg) ; (not (not ...)) -> ...
- (pair? (cdr arg)) ; this is usually internally generated, so the message about (and x #t) is in special-cases below
- (eq? arg-op 'not))
+ (pair? (cdr arg)) ; this is usually internally generated,
+ (eq? arg-op 'not)) ; so the message about (and x #t) is in special-case-functions below
(cadr arg))
((and (pair? arg) ; (not (or|and x (not y)...)) -> (and|or (not x) y ...)
@@ -2347,6 +2565,30 @@
(when (and (pair? arg1)
(pair? arg2))
+
+ (when (eq? (car arg1) 'not)
+ (if (symbol? (cadr arg1))
+ (if (memq (cadr arg1) arg2)
+ (begin
+ (if (eq? (car arg2) 'boolean?)
+ (return arg2))
+ (and-incomplete form 'or (cadr arg1) arg2 env))
+ (do ((p arg2 (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (memq (cadr arg1) (car p))))
+ (if (pair? p)
+ (and-incomplete form 'or (cadr arg1) (car p) env)))))
+ (if (and (pair? (cadr arg1)) ; (or (not (number? x)) (> x 2)) -> (or (not (real? x)) (> x 2))
+ (hash-table-ref bools (caadr arg1)))
+ (if (member (cadadr arg1) arg2)
+ (and-forgetful form 'or (cadr arg1) arg2 env)
+ (do ((p arg2 (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadadr arg1) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'or (cadr arg1) (car p) env))))))))
(if (and (eq? (car arg1) 'not) ; (or (not A) (and A B)) -> (or (not A) B) -- this stuff actually happens!
(eq? (car arg2) 'and)
@@ -2379,7 +2621,7 @@
(and-redundant? arg1 arg2))))
(if t1
(return (if (eq? t1 (car arg1)) arg2 arg1))))
-
+
;; if all clauses are (eq-func x y) where one of x/y is a symbol|simple-expr repeated throughout
;; and the y is a code-constant, or -> memq and friends.
;; This could also handle cadr|caddr reversed, but it apparently never happens.
@@ -2393,7 +2635,7 @@
(memq (car arg2) '(< <=)))
'<= '>=)
,@(cdr arg1))))
-
+
;; this makes some of the code above redundant
(let ((rel (relsub arg1 arg2 'or env)))
(if (or (boolean? rel)
@@ -2417,20 +2659,20 @@
;; perhaps also (or (not (or A B)) (not (or (not A) (not B)))), but it never happens
(let ((a1 (cadr form))
(a2 (caddr form)))
- (and (pair? a1)
- (pair? a2)
- (eq? (car a1) 'and)
- (eq? (car a2) 'and)
- (= (length a1) 3)
- (= (length a2) 3)
- (let ((A (if (and (pair? (cadr a1)) (eq? (caadr a1) 'not)) (cadadr a1) (cadr a1)))
- (B (if (and (pair? (caddr a1)) (eq? (caaddr a1) 'not)) (cadr (caddr a1)) (caddr a1))))
- (if (or (equal? form `(or (and ,A ,B) (and (not ,A) (not ,B))))
- (equal? form `(or (and (not ,A) (not ,B)) (and ,A ,B))))
- (return `(eq? (not ,A) (not ,B))))
- (if (or (equal? form `(or (and ,A (not ,B)) (and (not ,A) ,B)))
- (equal? form `(or (and (not ,A) ,B) (and ,A (not ,B)))))
- (return `(not (eq? (not ,A) (not ,B))))))))
+ (when (and (pair? a1)
+ (pair? a2)
+ (eq? (car a1) 'and)
+ (eq? (car a2) 'and)
+ (= (length a1) 3)
+ (= (length a2) 3))
+ (let ((A ((if (and (pair? (cadr a1)) (eq? (caadr a1) 'not)) cadadr cadr) a1))
+ (B (if (and (pair? (caddr a1)) (eq? (caaddr a1) 'not)) (cadr (caddr a1)) (caddr a1))))
+ (if (or (equal? form `(or (and ,A ,B) (and (not ,A) (not ,B))))
+ (equal? form `(or (and (not ,A) (not ,B)) (and ,A ,B))))
+ (return `(eq? (not ,A) (not ,B))))
+ (if (or (equal? form `(or (and ,A (not ,B)) (and (not ,A) ,B)))
+ (equal? form `(or (and (not ,A) ,B) (and ,A (not ,B)))))
+ (return `(not (eq? (not ,A) (not ,B))))))))
(when (and (pair? (cdr arg1))
(pair? (cdr arg2))
@@ -2542,7 +2784,7 @@
(constant-arg p)))
((eq? eqv?)
- (let ((leqf (car (->eqf (->lint-type (if (code-constant? (cadr p)) (cadr p) (caddr p)))))))
+ (let ((leqf (car (->eqf (->lint-type ((if (code-constant? (cadr p)) cadr caddr) p))))))
(cond ((not eqfnc)
(set! eqfnc leqf))
@@ -2598,18 +2840,16 @@
(set! vals (append (cadr (caddr p)) vals))))
(else #f)))
- (begin
- (if (not start)
- (set! start fp)
- (if (null? (cdr fp))
- (if (eq? start (cdr form))
- (return (gather-or-eqf-elements eqfnc sym vals))
- (return `(or ,@(copy (cdr form) (make-list (let loop ((g (cdr form)) (len 0))
- (if (eq? g start)
- len
- (loop (cdr g) (+ len 1))))))
- ,(gather-or-eqf-elements eqfnc sym vals)))))))
-
+ (if (not start)
+ (set! start fp)
+ (if (null? (cdr fp))
+ (if (eq? start (cdr form))
+ (return (gather-or-eqf-elements eqfnc sym vals))
+ (return `(or ,@(copy (cdr form) (make-list (let loop ((g (cdr form)) (len 0))
+ (if (eq? g start)
+ len
+ (loop (cdr g) (+ len 1))))))
+ ,(gather-or-eqf-elements eqfnc sym vals))))))
(when start
(if (eq? fp (cdr start))
(begin
@@ -2622,10 +2862,10 @@
(pair? (cdr fp))))
fp
(let ((nfp (simplify-boolean `(or , at fp) () () env)))
- (if (and (pair? nfp)
- (eq? (car nfp) 'or))
- (cdr nfp)
- (list nfp))))))
+ ((if (and (pair? nfp)
+ (eq? (car nfp) 'or))
+ cdr list)
+ nfp)))))
(if (eq? start (cdr form))
(return `(or ,(gather-or-eqf-elements eqfnc sym vals)
, at trailer))
@@ -2740,10 +2980,39 @@
`(or ,@(reverse new-form)))))))
(let ((val (classify (car exprs)))
(old-form new-form))
- (if (and (pair? val)
- (memq (car val) '(and or not)))
- (set! val (classify (simplify-boolean val true false env))))
-
+
+ (when (and (pair? val)
+ (memq (car val) '(and or not)))
+ (set! val (classify (simplify-boolean val true false env)))
+ (when (and (> len 3)
+ (pair? val)
+ (eq? (car val) 'not)
+ (pair? (cdr exprs)))
+ (if (symbol? (cadr val))
+ (if (and (pair? (cadr exprs))
+ (memq (cadr val) (cadr exprs)))
+ (and-incomplete form 'or (cadr val) (cadr exprs) env)
+ (do ((ip (cdr exprs) (cdr ip))
+ (found-it #f))
+ ((or found-it
+ (not (pair? ip))))
+ (do ((p (car ip) (cdr p)))
+ ((or (not (pair? p))
+ (and (memq (cadr val) p)
+ (set! found-it p)))
+ (if (pair? found-it)
+ (and-incomplete form 'or (cadr val) found-it env))))))
+ (when (and (pair? (cadr val))
+ (pair? (cadr exprs))
+ (hash-table-ref bools (caadr val)))
+ (if (member (cadadr val) (cadr exprs))
+ (and-forgetful form 'or (cadr val) (cadr exprs) env)
+ (do ((p (cadr exprs) (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadadr val) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'or (cadr val) (car p) env)))))))))
(if (not (or retry
(equal? val (car exprs))))
(set! retry #t))
@@ -2763,7 +3032,7 @@
((not (or (memq val new-form)
(and (pair? val) ; and redundant tests
- (hash-table-ref bools1 (car val))
+ (hash-table-ref booleans (car val))
(any? (lambda (p)
(and (pair? p)
(subsumes? (car p) (car val))
@@ -2773,7 +3042,7 @@
(if (and (not (eq? new-form old-form))
(pair? (cdr new-form)))
- (let ((rel (relsub (car new-form) (cadr new-form) 'or env)))
+ (let ((rel (relsub (cadr new-form) (car new-form) 'or env))) ; new-form is reversed
(if (or (boolean? rel)
(pair? rel))
(set! new-form (cons rel (cddr new-form)))))))))))))))
@@ -2802,35 +3071,33 @@
(return arg2))
;; the and equivalent of (or (not A) (and A B)) never happens
- (when (and (symbol? arg1) ; (and x (pair? x)) -> (pair? x)
- (pair? arg2)
- (pair? (cdr arg2))
- (eq? arg1 (cadr arg2)))
- (if (eq? (car arg2) 'not)
- (return #f))
- (if (not (or (memq (car arg2) '(and or not list cons vector))
- (side-effect? arg2 env)))
- (let ((v (var-member arg1 env)))
- (if (not (and (var? v)
- (pair? (var-history v))
- (member #f (var-history v)
- (lambda (a b)
- (and (pair? b)
- (memq (car b) '(char-position string-position format string->number
- assoc assq assv memq memv member)))))))
- (let* ((sig (arg-signature (car arg2) env))
- (arg-type (and (pair? sig)
- (pair? (cdr sig))
- (symbol? (cadr sig)))))
- (if arg-type
- (format outport "~NCin ~A, perhaps change ~S to ~S~%"
- lint-left-margin #\space
- (truncated-list->string form)
- `(and ,arg1 ...)
- `(and (,(cadr sig) ,arg1) ...)))))))
-
- (if (hash-table-ref bools1 (car arg2))
- (return arg2)))
+ (when (pair? arg2)
+ (if (symbol? arg1) ; (and x (pair? x)) -> (pair? x)
+ (if (memq arg1 arg2)
+ (begin
+ (if (eq? (car arg2) 'not)
+ (return #f))
+ (if (eq? (car arg2) 'boolean?)
+ (return `(eq? ,arg1 #t)))
+ (and-incomplete form 'and arg1 arg2 env)
+ (if (hash-table-ref booleans (car arg2))
+ (return arg2)))
+ (do ((p arg2 (cdr p))) ; (and x (+ (log x) 1)) -> (and (number? x)...)
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (memq arg1 (car p))))
+ (if (pair? p)
+ (and-incomplete form 'and arg1 (car p) env)))))
+ (if (and (pair? arg1) ; (and (number? x) (> x 2)) -> (and (real? x) (> x 2))
+ (hash-table-ref bools (car arg1)))
+ (if (member (cadr arg1) arg2)
+ (and-forgetful form 'and arg1 arg2 env)
+ (do ((p arg2 (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadr arg1) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'and arg1 (car p) env))))))))
(if (and (not (side-effect? arg1 env))
(equal? arg1 arg2)) ; (and x x) -> x
@@ -2853,7 +3120,7 @@
`(,t1 ,@(cdr arg2)))
((eq? t1 'memv)
- (let ((x (if (equal? (cadr arg1) (cadr arg2)) (caddr arg2) (cadr arg2))))
+ (let ((x ((if (equal? (cadr arg1) (cadr arg2)) caddr cadr) arg2)))
(if (rational? x)
`(memv ,(cadr arg1) '(,x ,(* 1.0 x)))
`(memv ,(cadr arg1) '(,(floor x) ,x)))))
@@ -2930,7 +3197,7 @@
(and (pair? (cddr arg2))
(null? (cdddr arg2))
(equal? (cadr arg1) (caddr arg2))))
- (hash-table-ref bools1 (car arg1)))
+ (hash-table-ref booleans (car arg1)))
(when (or (eq? (car arg1) 'zero?) ; perhaps rational? and integer? here -- not many hits
(eq? (car arg2) 'zero?))
@@ -2941,11 +3208,7 @@
(eq? (car arg2) 'inexact?))
(return `(eqv? ,(cadr arg1) 0.0))))
- (when (memq (car arg2) '(< = > <= >= char-ci>=? char-ci<? char-ready? char<? char-ci=? char>?
- char<=? char-ci>? char-ci<=? char>=? char=? string-ci<=? string=?
- string-ci>=? string<? string-ci<? string-ci=? string-ci>? string>=? string<=? string>?
- eqv? equal? eq? morally-equal?))
-
+ (when (hash-table-ref and-rel-ops (car arg2))
(when (and (eq? (car arg1) 'symbol?)
(memq (car arg2) '(eq? eqv? equal?))
(or (quoted-symbol? (cadr arg2))
@@ -2957,6 +3220,11 @@
(eq? (cadr arg1) (cadr arg2)))
(return `(< 0 ,(cadr arg1) ,(caddr arg2))))))
+ (when (and (equal? (cadr arg1) (cadr arg2))
+ (eq? (car arg1) 'inexact?)
+ (eq? (car arg2) 'real?))
+ (return `(and ,arg2 ,arg1)))
+
;; this makes some of the code above redundant
(let ((rel (relsub arg1 arg2 'and env)))
(if (or (boolean? rel)
@@ -2993,9 +3261,7 @@
(let ((arg-type (and (> (length sig) pos)
(list-ref sig pos))))
(unless (compatible? (car arg1) arg-type)
- (let ((ln (and (positive? line-number)
- (< line-number 100000)
- line-number)))
+ (let ((ln (and (< 0 line-number 100000) line-number)))
(format outport "~NCin ~A~A, ~A is ~A, but ~A wants ~A"
lint-left-margin #\space
(truncated-list->string form)
@@ -3060,7 +3326,7 @@
(when diff
(if (null? (cdr diff))
(return (car diff)))
- (return `(and , at diff))))
+ (return (simplify-boolean `(and , at diff) () () env))))
;; now there are redundancies below (see subsumes?) but they assumed the tests were side-by-side
(let ((new-form ())
@@ -3096,9 +3362,59 @@
(let* ((e (car exprs))
(val (classify e))
(old-form new-form))
+
(if (and (pair? val)
(memq (car val) '(and or not)))
- (set! val (classify (set! e (simplify-boolean val () false env)))))
+ (set! val (classify (set! e (simplify-boolean val () false env))))
+
+ (when (and (> len 3)
+ (pair? (cdr exprs)))
+ (if (symbol? val)
+ (if (and (pair? (cadr exprs))
+ (memq val (cadr exprs)))
+ (let ((nval (simplify-boolean `(and ,val ,(cadr exprs)) () false env)))
+ (if (and (pair? nval)
+ (eq? (car nval) 'and))
+ (and-incomplete form 'and val (cadr exprs) env)
+ (begin
+ (set! val nval)
+ (set! exprs (cdr exprs)))))
+ (do ((ip (cdr exprs) (cdr ip))
+ (found-it #f))
+ ((or found-it
+ (not (pair? ip))))
+ (do ((p (car ip) (cdr p)))
+ ((or (not (pair? p))
+ (and (memq val p)
+ (let ((nval (simplify-boolean `(and ,val ,p) () false env)))
+ (if (and (pair? nval)
+ (eq? (car nval) 'and))
+ (set! found-it p)
+ (let ((ln (and (< 0 line-number 100000) line-number)))
+ (format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~%"
+ lint-left-margin #\space
+ (truncated-list->string form)
+ (if ln (format #f " (line ~D)" ln) "")
+ (+ lint-left-margin 4) #\space
+ `(and ... ,val ... ,p)
+ nval)
+ (set! found-it #t)))))
+ (and (pair? (car p))
+ (memq val (car p))
+ (set! found-it (car p))))
+ (if (pair? found-it)
+ (and-incomplete form 'and val found-it env))))))
+ (if (and (pair? val)
+ (pair? (cadr exprs))
+ (hash-table-ref bools (car val)))
+ (if (member (cadr val) (cadr exprs))
+ (and-forgetful form 'and val (cadr exprs) env)
+ (do ((p (cadr exprs) (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadr val) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'and val (car p) env)))))))))
(if (not (or retry
(equal? e (car exprs))))
@@ -3124,7 +3440,7 @@
(or (null? new-form)
(not (member e new-form))))
(set! new-form (cons e new-form)))))
-
+
((not val) ; #f in 'and' ends the expression
(set! new-form (if (or (null? new-form)
(just-symbols? new-form))
@@ -3146,7 +3462,7 @@
(if (not (and (pair? new-form)
(or (eq? val (car new-form)) ; omit repeated tests
(and (pair? val) ; and redundant tests
- (hash-table-ref bools1 (car val))
+ (hash-table-ref booleans (car val))
(any? (lambda (p)
(and (pair? p)
(subsumes? (car val) (car p))
@@ -3159,6 +3475,7 @@
(let ((rel (relsub (car new-form) (cadr new-form) 'and env)))
;; rel #f should halt everything as above, and it looks ugly in the output,
;; but it never happens in real code
+ ;(format *stderr* "~A -> rel: ~A~%" new-form rel)
(if (or (pair? rel)
(boolean? rel))
(set! new-form (cons rel (cddr new-form)))))))))))))))))))))))))
@@ -3222,6 +3539,28 @@
(lambda ignore f))
f))))
+ (define (remove-inexactions val)
+ (when (and (or (assq 'exact->inexact val)
+ (assq 'inexact val))
+ (not (tree-member 'random val))
+ (any? number? val))
+ (set! val (map (lambda (x)
+ (if (and (pair? x)
+ (memq (car x) '(inexact exact->inexact)))
+ (cadr x)
+ x))
+ val))
+ (if (not (any? (lambda (x)
+ (and (number? x)
+ (inexact? x)))
+ val))
+ (do ((p val (cdr p)))
+ ((or (null? p)
+ (number? (car p)))
+ (if (pair? p)
+ (set-car! p (* 1.0 (car p))))))))
+ val)
+
(let* ((args (map simplify-arg (cdr form)))
(len (length args)))
(case (car form)
@@ -3240,7 +3579,7 @@
(set! val (if (zero? y)
(collect-if list (lambda (x) (not (number? x))) val)
(cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
-
+ (set! val (remove-inexactions val))
(if (any? (lambda (p) ; collect all + and - vals -> (- (+ ...) ...)
(and (pair? p)
(eq? (car p) '-)))
@@ -3338,6 +3677,8 @@
(set! val (if (= y 1)
(collect-if list (lambda (x) (not (number? x))) val)
(cons y (collect-if list (lambda (x) (not (number? x))) val))))))))
+ (set! val (remove-inexactions val))
+
(case (length val)
((0) 1)
((1) (car val)) ; (* x) -> x
@@ -3358,54 +3699,46 @@
((and (pair? arg1)
(pair? arg2))
- (cond ((and (eq? (car arg1) '-) ; (* (- x) (- y)) -> (* x y)
- (null? (cddr arg1))
- (eq? (car arg2) '-)
- (null? (cddr arg2)))
- `(* ,(cadr arg1) ,(cadr arg2)))
-
- ((and (pair? arg1) ; (* (/ x) (/ y)) -> (/ (* x y)) etc
- (pair? arg2)
- (eq? (car arg1) '/)
- (eq? (car arg2) '/))
- (if (null? (cddr arg1))
- (if (null? (cddr arg2))
- `(/ (* ,(cadr arg1) ,(cadr arg2)))
- (if (equal? (cadr arg1) (cadr arg2))
- `(/ ,(caddr arg2))
- (simplify-numerics `(/ ,(cadr arg2) (* ,(cadr arg1) ,(caddr arg2))) env)))
- (if (null? (cddr arg2))
- (if (equal? (cadr arg1) (cadr arg2))
- `(/ ,(caddr arg1))
- (simplify-numerics `(/ ,(cadr arg1) (* ,(caddr arg1) ,(cadr arg2))) env))
- (simplify-numerics `(/ (* ,(cadr arg1) ,(cadr arg2)) (* ,@(cddr arg1) ,@(cddr arg2))) env))))
-
- ((and (= (length arg1) 3)
- (equal? (cdr arg1) (cdr arg2))
- (case (car arg1)
- ((gcd) (eq? (car arg2) 'lcm))
- ((lcm) (eq? (car arg2) 'gcd))
- (else #f)))
- `(abs (* ,@(cdr arg1)))) ; (* (gcd a b) (lcm a b)) -> (abs (* a b)) but only if 2 args?
-
- ((and (eq? (car arg1) 'exp) ; (* (exp a) (exp b)) -> (exp (+ a b))
- (eq? (car arg2) 'exp))
- `(exp (+ ,(cadr arg1) ,(cadr arg2))))
-
- (else `(* , at val))))
-
- ((and (pair? arg1) ; (* (inexact->exact x) 2.0) -> (* x 2.0)
- (memq (car arg1) '(exact->inexact inexact))
- (number? arg2)
- (not (rational? arg2)))
- `(* ,(cadr arg1) ,arg2))
-
- ((and (pair? arg2) ; (* 2.0 (inexact x)) -> (* 2.0 x)
- (memq (car arg2) '(exact->inexact inexact))
- (number? arg1)
- (not (rational? arg1)))
- `(* ,arg1 ,(cadr arg2)))
-
+ (let ((op1 (car arg1))
+ (op2 (car arg2)))
+ (cond ((and (eq? op1 '-) ; (* (- x) (- y)) -> (* x y)
+ (null? (cddr arg1))
+ (eq? op2 '-)
+ (null? (cddr arg2)))
+ `(* ,(cadr arg1) ,(cadr arg2)))
+
+ ((and (pair? arg1) ; (* (/ x) (/ y)) -> (/ (* x y)) etc
+ (pair? arg2)
+ (eq? op1 '/)
+ (eq? op2 '/))
+ (let ((op1-arg1 (cadr arg1))
+ (op2-arg1 (cadr arg2)))
+ (if (null? (cddr arg1))
+ (if (null? (cddr arg2))
+ `(/ (* ,op1-arg1 ,op2-arg1))
+ (if (equal? op1-arg1 op2-arg1)
+ `(/ ,(caddr arg2))
+ (simplify-numerics `(/ ,op2-arg1 (* ,op1-arg1 ,(caddr arg2))) env)))
+ (if (null? (cddr arg2))
+ (if (equal? op1-arg1 op2-arg1)
+ `(/ ,(caddr arg1))
+ (simplify-numerics `(/ ,op1-arg1 (* ,(caddr arg1) ,op2-arg1)) env))
+ (simplify-numerics `(/ (* ,op1-arg1 ,op2-arg1) (* ,@(cddr arg1) ,@(cddr arg2))) env)))))
+
+ ((and (= (length arg1) 3)
+ (equal? (cdr arg1) (cdr arg2))
+ (case op1
+ ((gcd) (eq? op2 'lcm))
+ ((lcm) (eq? op2 'gcd))
+ (else #f)))
+ `(abs (* ,@(cdr arg1)))) ; (* (gcd a b) (lcm a b)) -> (abs (* a b)) but only if 2 args?
+
+ ((and (eq? op1 'exp) ; (* (exp a) (exp b)) -> (exp (+ a b))
+ (eq? op2 'exp))
+ `(exp (+ ,(cadr arg1) ,(cadr arg2))))
+
+ (else `(* , at val)))))
+
((and (number? arg1) ; (* 2 (random 3.0)) -> (random 6.0)
(pair? arg2)
(eq? (car arg2) 'random)
@@ -3443,11 +3776,24 @@
(set! mul (cons (cadr p) mul))
(set! div (append (cddr p) div))))))
val)
- (simplify-numerics `(/ (* ,@(reverse mul)) ,@(reverse div)) env)))
+ (for-each (lambda (n)
+ (when (member n div)
+ (set! div (remove n div))
+ (set! mul (remove n mul))))
+ (copy mul))
+ (let ((expr (if (null? mul)
+ (if (null? div)
+ `(*) ; for simplify-numerics' benefit
+ `(/ 1 ,@(reverse div)))
+ (if (null? div)
+ `(* ,@(reverse mul))
+ `(/ (* ,@(reverse mul)) ,@(reverse div))))))
+ (simplify-numerics expr env))))
(else `(* , at val)))))))))
((-)
+ (set! args (remove-inexactions args))
(case len
((0) form)
((1) ; negate
@@ -3540,6 +3886,7 @@
(else (simplify-numerics `(- (+ ,(cadar args) ,@(cdr args))) env)))))))))
((/)
+ (set! args (remove-inexactions args))
(case len
((0) form)
((1) ; invert
@@ -3547,40 +3894,55 @@
(if (zero? (car args))
`(/ ,(car args))
(/ (car args)))
- (if (and (pair? (car args)) ; (/ (/ x)) -> x
- (= (length (car args)) 2)
- (eq? (caar args) '/))
- (cadar args)
- `(/ , at args))))
+ (if (not (pair? (car args)))
+ `(/ , at args)
+ (case (caar args)
+ ((/)
+ (case (length (car args))
+ ((2) ; (/ (/ x)) -> x
+ (cadar args))
+ ((3) ; (/ (/ z x)) -> (/ x z)
+ `(/ ,@(reverse (cdar args))))
+ (else
+ (if (eqv? (cadar args) 1)
+ `(* ,@(cddar args)) ; (/ (/ 1 x y)) -> (* x y)
+ `(/ (* ,@(cddar args)) ,(cadar args)))))) ; (/ (/ z x y)) -> (/ (* x y) z)
+ ((expt) ; (/ (expt x y)) -> (expt x (- y))
+ `(expt ,(cadar args) (- ,(caddar args))))
+ ((exp) ; (/ (exp x)) -> (exp (- x))
+ `(exp (- ,(cadar args))))
+ (else `(/ , at args))))))
((2)
(if (and (just-rationals? args)
(not (zero? (cadr args))))
(apply / args) ; including (/ 0 12) -> 0
- (let ((arg1 (car args))
- (arg2 (cadr args)))
+ (let* ((arg1 (car args))
+ (arg2 (cadr args))
+ (op1 (and (pair? arg1) (car arg1)))
+ (op2 (and (pair? arg2) (car arg2))))
(cond ((eqv? arg1 1) ; (/ 1 x) -> (/ x)
- `(/ ,arg2))
+ (simplify-numerics `(/ ,arg2) env))
((eqv? arg2 1) ; (/ x 1) -> x
arg1)
((and (pair? arg1) ; (/ (/ a b) c) -> (/ a b c)
- (eq? (car arg1) '/)
+ (eq? op1 '/)
(pair? (cddr arg1))
(not (and (pair? arg2)
- (eq? (car arg2) '/))))
+ (eq? op2 '/))))
`(/ ,(cadr arg1) ,@(cddr arg1) ,arg2))
((and (pair? arg1) ; (/ (/ a) (/ b)) -> (/ b a)??
- (eq? (car arg1) '/)
+ (eq? op1 '/)
(pair? arg2)
- (eq? '/ (car arg2)))
+ (eq? '/ op2))
(let ((a1 (if (null? (cddr arg1)) `(/ 1 ,(cadr arg1)) arg1))
(a2 (if (null? (cddr arg2)) `(/ 1 ,(cadr arg2)) arg2)))
(simplify-numerics `(/ (* ,(cadr a1) ,@(cddr a2)) (* ,@(cddr a1) ,(cadr a2))) env)))
((and (pair? arg2)
- (eq? (car arg2) '*)
+ (eq? op2 '*)
(not (side-effect? arg1 env))
(member arg1 (cdr arg2)))
(let ((n (remove arg1 (cdr arg2))))
@@ -3589,7 +3951,7 @@
`(/ 1 , at n)))) ; (/ x (* y x z)) -> (/ 1 y z)
((and (pair? arg2) ; (/ c (/ a b)) -> (/ (* c b) a)
- (eq? (car arg2) '/))
+ (eq? op2 '/))
(cond ((null? (cddr arg2))
`(* ,arg1 ,(cadr arg2))) ; ignoring divide by zero here (/ x (/ y)) -> (* x y)
((eqv? (cadr arg2) 1)
@@ -3609,37 +3971,57 @@
#|
;; can't decide about this -- result usually looks cruddy
((and (pair? arg2) ; (/ x (* y z)) -> (/ x y z)
- (eq? (car arg2) '*))
+ (eq? op2 '*))
`(/ ,arg1 ,@(cdr arg2)))
|#
((and (pair? arg1) ; (/ (log x) (log y)) -> (log x y)
(pair? arg2)
(= (length arg1) (length arg2) 2)
- (eq? (car arg1) 'log)
- (eq? (car arg2) 'log)) ; other possibilities here don't happen
- `(log ,(cadr arg1) ,(cadr arg2)))
-
- ((and (pair? arg1) ; (/ (inexact x) 2.0) -> (/ x 2.0)
- (memq (car arg1) '(exact->inexact inexact))
- (number? arg2)
- (not (rational? arg2)))
- `(/ ,(cadr arg1) ,arg2))
-
- ((and (pair? arg2) ; (/ 2.0 (inexact x)) -> (/ 2.0 x)
- (memq (car arg2) '(exact->inexact inexact))
- (number? arg1)
- (not (rational? arg1)))
- `(/ ,arg1 ,(cadr arg2)))
-
- ((and (pair? arg1) ; (/ (- x) (- y)) -> (/ x y)
+ (case op1
+ ((log) (eq? op2 'log))
+ ((sin)
+ (and (eq? op2 'cos)
+ (equal? (cadr arg1) (cadr arg2))))
+ (else #f)))
+ (if (eq? op1 'log)
+ `(log ,(cadr arg1) ,(cadr arg2))
+ `(tan ,(cadr arg1))))
+
+ ((and (pair? arg1) ; (/ (- x) (- y)) -> (/ x y)
(pair? arg2)
- (eq? (car arg1) '-)
- (eq? (car arg2) '-)
+ (eq? op1 '-)
+ (eq? op2 '-)
(= (length arg1) (length arg2) 2))
`(/ ,(cadr arg1) ,(cadr arg2)))
+ ((and (pair? arg1) ; (/ (* x y) (* z y)) -> (/ x z)
+ (pair? arg2)
+ (eq? op1 '*)
+ (case op2
+ ((*)
+ (and (= (length arg1) (length arg2) 3)
+ (equal? (caddr arg1) (caddr arg2))))
+ ((log)
+ (cond ((assq 'log (cdr arg1))
+ => (lambda (p)
+ (= (length p) 2)))
+ (else #f)))
+ (else #f)) ; (/ (* 12 (log x)) (log 2)) -> (* 12 (log x 2))
+ (if (eq? op2 '*)
+ `(/ ,(cadr arg1) ,(cadr arg2))
+ (let ((used-log (cadr arg2)))
+ `(* ,@(map (lambda (p)
+ (if (and used-log
+ (pair? p)
+ (eq? (car p) 'log))
+ (let ((val `(log ,(cadr p) ,used-log)))
+ (set! used-log #f)
+ val)
+ p))
+ (cdr arg1)))))))
+
(else `(/ , at args))))))
-
+
(else
(if (and (just-rationals? args)
(not (memv 0 (cdr args)))
@@ -3674,10 +4056,14 @@
(eq? (caar args) '-)
(null? (cddar args)))
`(cos ,(cadar args)))
- ((eq? (car args) 'pi) ; (sin pi) -> 0.0
+ ((or (eq? (car args) 'pi) ; (sin pi) -> 0.0
+ (and (pair? (car args))
+ (eq? (caar args) '-)
+ (eq? (cadar args) 'pi)
+ (null? (cddar args))))
(case (car form)
((sin tan) 0.0)
- ((cos) 1.0)
+ ((cos) -1.0)
(else `(,(car form) , at args))))
((eqv? (car args) 0.0) ; (sin 0.0) -> 0.0
((symbol->value (car form)) 0.0))
@@ -3772,7 +4158,7 @@
((and (pair? (car args)) ; (abs (modulo x 2)) -> (modulo x 2)
(memq (caar args) '(modulo random))
(= (length (car args)) 3)
- (number? (caddar args))
+ (real? (caddar args))
(positive? (caddar args)))
(car args))
((and (pair? (car args)) ; (abs (- x)) -> (abs x)
@@ -3937,12 +4323,33 @@
(else `(,(car form) , at args))))
((exact->inexact inexact)
- (if (not (= len 1))
- form
- (if (memv (car args) '(0 0.0))
- 0.0
- ;; not (inexact (random 3)) -> (random 3.0) because results are different
- `(,(car form) , at args))))
+ (cond ((not (= len 1))
+ form)
+
+ ((memv (car args) '(0 0.0))
+ 0.0)
+
+ ((or (not (pair? (car args)))
+ (eq? (caar args) 'random)
+ (not (hash-table-ref numeric-ops (caar args)))
+ (not (any? number? (cdar args))))
+ `(,(car form) , at args))
+
+ ((any? (lambda (x)
+ (and (number? x)
+ (inexact? x)))
+ (cdar args))
+ (car args))
+
+ (else
+ (let ((new-form (copy (car args))))
+ (do ((p (cdr new-form) (cdr p)))
+ ((or (null? p)
+ (number? (car p)))
+ (if (pair? p)
+ (set-car! p (* 1.0 (car p))))
+ new-form))))))
+ ;; not (inexact (random 3)) -> (random 3.0) because results are different
((logior)
(set! args (lint-remove-duplicates (remove-all 0 (splice-if (lambda (x) (eq? x 'logior)) args)) env))
@@ -4023,6 +4430,14 @@
form
(begin
(set! args (lint-remove-duplicates (splice-if (lambda (x) (eq? x (car form))) args) env))
+ (if (any? (lambda (p) ; if non-negative-op, remove any non-positive numbers
+ (and (pair? p)
+ (hash-table-ref non-negative-ops (car p))))
+ args)
+ (set! args (remove-if (lambda (x)
+ (and (real? x)
+ (not (positive? x))))
+ args)))
(if (= len 1)
(car args)
(if (just-reals? args)
@@ -4086,9 +4501,7 @@
(lists->string form
`(,(case op ((=) 'char=?) ((>) 'char>?) ((<) 'char<?) ((>=) 'char>=?) (else 'char<=?))
,@(map (lambda (arg)
- (if (integer? arg)
- (integer->char arg)
- (cadr arg)))
+ ((if (integer? arg) integer->char cadr) arg))
(cdr form)))))))
(define (write-port expr) ; ()=not specified (*stdout*), #f=something is wrong (not enough args)
@@ -4104,7 +4517,7 @@
(define (display->format d)
(case (car d)
- ((newline) "~%")
+ ((newline) (copy "~%"))
((display)
(let* ((arg (cadr d))
@@ -4233,16 +4646,34 @@
(define (unrelop caller head form) ; assume len=3
(let ((arg1 (cadr form))
(arg2 (caddr form)))
- (if (memv arg2 '(0 0.0)) ; (< (- x y) 0) -> (< x y), need both 0 and 0.0 because (eqv? 0 0.0) is #f
- (if (and (pair? arg1)
- (eq? (car arg1) '-)
- (= (length arg1) 3))
- (lint-format "perhaps ~A" caller (lists->string form `(,head ,(cadr arg1) ,(caddr arg1)))))
- (if (and (memv arg1 '(0 0.0)) ; (< 0 (- x y)) -> (> x y)
- (pair? arg2)
- (eq? (car arg2) '-)
+ (if (and (pair? arg1)
+ (= (length arg1) 3))
+ (if (eq? (car arg1) '-)
+ (if (memv arg2 '(0 0.0)) ; (< (- x y) 0) -> (< x y), need both 0 and 0.0 because (eqv? 0 0.0) is #f
+ (lint-format "perhaps ~A" caller (lists->string form `(,head ,(cadr arg1) ,(caddr arg1))))
+ (if (and (integer? arg2) ; (> (- x 50868) 256) -> (> x 51124)
+ (integer? (caddr arg1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,head ,(cadr arg1) ,(+ (caddr arg1) arg2))))))
+ (if (and (eq? (car arg1) '+) ; (< (+ x 1) 3) -> (< x 2)
+ (integer? arg2)
+ (integer? (caddr arg1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,head ,(cadr arg1) ,(- arg2 (caddr arg1)))))))
+ (if (and (pair? arg2)
(= (length arg2) 3))
- (lint-format "perhaps ~A" caller (lists->string form `(,(hash-table-ref reversibles head) ,(cadr arg2) ,(caddr arg2))))))))
+ (if (eq? (car arg2) '-)
+ (if (memv arg1 '(0 0.0)) ; (< 0 (- x y)) -> (> x y)
+ (lint-format "perhaps ~A" caller (lists->string form `(,(hash-table-ref reversibles head)
+ ,(cadr arg2) ,(caddr arg2))))
+ (if (and (integer? arg1)
+ (integer? (caddr arg2)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(hash-table-ref reversibles head)
+ ,(cadr arg2) ,(+ arg1 (caddr arg2)))))))
+ (if (and (eq? (car arg2) '+)
+ (integer? arg1)
+ (integer? (caddr arg2)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(hash-table-ref reversibles head)
+ ,(cadr arg2) ,(- arg1 (caddr arg2)))))))))))
+
(define (check-start-and-end caller head form ff env)
(if (or (and (integer? (car form))
@@ -4253,9 +4684,7 @@
(lint-format "these ~A indices make no sense: ~A" caller head ff)))
(define (other-case c)
- (if (char-upper-case? c)
- (char-downcase c)
- (char-upcase c)))
+ ((if (char-upper-case? c) char-downcase char-upcase) c))
(define (check-boolean-affinity caller form env)
;; does built-in boolean func's arg make sense
@@ -4297,6 +4726,9 @@
(if arg2 (innards (car arg2)) "")
(if arg3 (innards (car arg3)) ""))
(cadr (or arg3 arg2 arg1)))))))
+
+ (define combinable-cxrs '(car cdr caar cadr cddr cdar caaar caadr caddr cdddr cdaar cddar cadar cdadr cadddr cddddr))
+ ;; caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar
(define (mv-range producer env)
(if (symbol? producer)
@@ -4326,2215 +4758,2899 @@
(lambda args
#t))))
+ (define (unbegin x)
+ ((if (and (pair? x)
+ (eq? (car x) 'begin))
+ cdr list)
+ x))
- (define (check-special-cases caller head form env)
- ;; here curlet won't change (leaving aside additions via define)
- ;; keyword head here if args to func/macro that we don't know about
-
- (case head
-
- ;; ----------------
- ((memq assq memv assv member assoc)
-
- (define (list-one? p)
- (and (pair? p)
- (pair? (cdr p))
- (null? (cddr p))
- (case (car p)
- ((list) cadr)
- ((quote)
- (and (pair? (cadr p))
- (null? (cdadr p))
- (if (symbol? (caadr p))
- (lambda (x)
- (list 'quote (caadr x)))
- caadr)))
- (else #f))))
-
- (when (= (length form) 4)
- (let ((func (list-ref form 3)))
- (if (symbol? func)
- (if (memq func '(eq? eqv? equal?)) ; (member x y eq?) -> (memq x y)
- (let ((op (if (eq? head 'member)
- (case func ((eq?) 'memq) ((eqv?) 'memv) (else 'member))
- (case func ((eq?) 'assq) ((eqv?) 'assv) (else 'assoc)))))
- (lint-format "perhaps ~A" caller (lists->string form `(,op ,(cadr form) ,(caddr form)))))
- (let ((sig (procedure-signature (symbol->value func)))) ; arg-signature here is too cranky
- (if (and sig
- (not (eq? (car sig) 'boolean?)))
- (lint-format "~A is a questionable ~A function" caller func head))))
- ;; func not a symbol
- (if (and (pair? func)
- (= (length func) 3)
- (eq? (car func) 'lambda)
- (pair? (cadr func))
- (pair? (caddr func)))
- (if (not (memv (length (cadr func)) '(2 -1)))
- (lint-format "~A equality function (optional third arg) should take two arguments" caller head)
- (if (eq? head 'member)
- (let ((eq (caddr func))
- (args (cadr func)))
- (if (and (memq (car eq) '(eq? eqv? equal?))
- (eq? (car args) (cadr eq))
- (pair? (caddr eq))
- (eq? (car (caddr eq)) 'car)
- (pair? (cdr (caddr eq)))
- (pair? (cdr args))
- (eq? (cadr args) (cadr (caddr eq))))
- (lint-format "member might perhaps be ~A"
- caller
- (if (or (eq? func 'eq?)
- (eq? (car (caddr func)) 'eq?))
- 'assq
- (if (eq? (car (caddr func)) 'eqv?)
- 'assv
- 'assoc)))))))))))
-
- (when (= (length form) 3)
- (let ((selector (cadr form))
- (items (caddr form)))
-
- (let ((current-eqf (case head ((memq assq) 'eq?) ((memv assv) 'eqv?) (else 'equal?)))
- (selector-eqf (eqf selector env))
- (one-item (and (memq head '(memq memv member)) (list-one? items))))
- ;; one-item assoc doesn't simplify cleanly
-
- (if one-item
- (let* ((target (one-item items))
- (iter-eqf (eqf target env)))
- (if (or (symbol? target)
- (and (pair? target)
- (not (eq? (car target) 'quote))))
- (set! target (list 'quote target)))
- (lint-format "perhaps ~A" caller (lists->string form `(,(cadr iter-eqf) ,selector ,target))))
-
- ;; not one-item
- (letrec ((duplicates? (lambda (lst fnc)
- (and (pair? lst)
- (or (fnc (car lst) (cdr lst))
- (duplicates? (cdr lst) fnc)))))
- (duplicate-constants? (lambda (lst fnc)
- (and (pair? lst)
- (or (and (constant? (car lst))
- (fnc (car lst) (cdr lst)))
- (duplicate-constants? (cdr lst) fnc))))))
- (if (and (pair? items)
- (or (eq? (car items) 'list)
- (and (eq? (car items) 'quote)
- (pair? (cadr items)))))
- (let ((baddy #f))
- (catch #t
- (lambda ()
- (set! baddy (if (eq? (car items) 'list)
- (duplicate-constants? (cdr items) (symbol->value head))
- (duplicates? (cadr items) (symbol->value head)))))
- (lambda args #f))
- (if (pair? baddy)
- (lint-format "duplicated entry ~S in ~A" caller (car baddy) items))))
+
+ (define special-case-functions
+ (let ((h (make-hash-table)))
+
+ ;; ---------------- member and assoc ----------------
+ (let ()
+ (define (sp-memx caller head form env)
+
+ (define (list-one? p)
+ (and (pair? p)
+ (pair? (cdr p))
+ (null? (cddr p))
+ (case (car p)
+ ((list) cadr)
+ ((quote)
+ (and (pair? (cadr p))
+ (null? (cdadr p))
+ (if (symbol? (caadr p))
+ (lambda (x)
+ (list 'quote (caadr x)))
+ caadr)))
+ (else #f))))
+
+ (when (= (length form) 4)
+ (let ((func (list-ref form 3)))
+ (if (symbol? func)
+ (if (memq func '(eq? eqv? equal?)) ; (member x y eq?) -> (memq x y)
+ (let ((op (if (eq? head 'member)
+ (case func ((eq?) 'memq) ((eqv?) 'memv) (else 'member))
+ (case func ((eq?) 'assq) ((eqv?) 'assv) (else 'assoc)))))
+ (lint-format "perhaps ~A" caller (lists->string form `(,op ,(cadr form) ,(caddr form)))))
+ (let ((sig (procedure-signature (symbol->value func)))) ; arg-signature here is too cranky
+ (if (and (pair? sig)
+ (not (eq? 'boolean? (car sig)))
+ (not (and (pair? (car sig))
+ (memq 'boolean? (car sig)))))
+ (lint-format "~A is a questionable ~A function" caller func head))))
+ ;; func not a symbol
+ (if (and (pair? func)
+ (= (length func) 3)
+ (eq? (car func) 'lambda)
+ (pair? (cadr func))
+ (pair? (caddr func)))
+ (if (not (memv (length (cadr func)) '(2 -1)))
+ (lint-format "~A equality function (optional third arg) should take two arguments" caller head)
+ (if (eq? head 'member)
+ (let ((eq (caddr func))
+ (args (cadr func)))
+ (if (and (memq (car eq) '(eq? eqv? equal?))
+ (eq? (car args) (cadr eq))
+ (pair? (caddr eq))
+ (eq? (car (caddr eq)) 'car)
+ (pair? (cdr (caddr eq)))
+ (pair? (cdr args))
+ (eq? (cadr args) (cadr (caddr eq))))
+ (lint-format "member might perhaps be ~A"
+ caller
+ (if (or (eq? func 'eq?)
+ (eq? (car (caddr func)) 'eq?))
+ 'assq
+ (if (eq? (car (caddr func)) 'eqv?)
+ 'assv
+ 'assoc)))))))))))
+
+ (when (= (length form) 3)
+ (let ((selector (cadr form))
+ (items (caddr form)))
+
+ (let ((current-eqf (case head ((memq assq) 'eq?) ((memv assv) 'eqv?) (else 'equal?)))
+ (selector-eqf (eqf selector env))
+ (one-item (and (memq head '(memq memv member)) (list-one? items))))
+ ;; one-item assoc doesn't simplify cleanly
+
+ (if one-item
+ (let* ((target (one-item items))
+ (iter-eqf (eqf target env)))
+ (if (or (symbol? target)
+ (and (pair? target)
+ (not (eq? (car target) 'quote))))
+ (set! target (list 'quote target)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(cadr iter-eqf) ,selector ,target))))
+
+ ;; not one-item
+ (letrec ((duplicates? (lambda (lst fnc)
+ (and (pair? lst)
+ (or (fnc (car lst) (cdr lst))
+ (duplicates? (cdr lst) fnc)))))
+ (duplicate-constants? (lambda (lst fnc)
+ (and (pair? lst)
+ (or (and (constant? (car lst))
+ (fnc (car lst) (cdr lst)))
+ (duplicate-constants? (cdr lst) fnc))))))
+ (if (and (symbol? (car selector-eqf))
+ (not (eq? (car selector-eqf) current-eqf)))
+ (lint-format "~A: perhaps ~A -> ~A" caller (truncated-list->string form) head
+ (if (memq head '(memq memv member))
+ (case (car selector-eqf) ((eq?) 'memq) ((eqv?) 'memv) ((equal?) 'member))
+ (case (car selector-eqf) ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc)))))
+
+ ;; --------------------------------
+ ;; check for head mismatch with items
+ (when (pair? items)
+ (when (or (eq? (car items) 'list)
+ (and (eq? (car items) 'quote)
+ (pair? (cadr items))))
+ (let ((elements ((if (eq? (car items) 'quote) cadr cdr) items)))
+ (let ((baddy #f))
+ (catch #t
+ (lambda ()
+ (set! baddy ((if (eq? (car items) 'list) duplicate-constants? duplicates?)
+ elements (symbol->value head))))
+ (lambda args #f))
+ (if (pair? baddy)
+ (lint-format "duplicated entry ~S in ~A" caller (car baddy) items)))
+
+ (when (proper-list? elements)
+ (let ((maxf #f)
+ (keys (if (eq? (car items) 'quote)
+ (if (memq head '(memq memv member))
+ elements
+ (and (every? pair? elements)
+ (map car elements)))
+ (if (memq head '(memq memv member))
+ (and (every? code-constant? elements)
+ elements)
+ (and (every? (lambda (e)
+ (and (pair? e)
+ (eq? (car e) 'quote)))
+ elements)
+ (map caadr elements))))))
+ (when (proper-list? keys)
+ (if (eq? (car items) 'quote)
+ (do ((p keys (cdr p)))
+ ((or (null? p)
+ (memq maxf '(equal? #t))))
+ (let ((element (car p)))
+ (if (symbol? element)
+ (if (not maxf)
+ (set! maxf 'eq?))
+ (if (pair? element)
+ (begin
+ (if (and (eq? (car element) 'quote)
+ (pair? (cdr element)))
+ (lint-format "stray quote? ~A" caller form))
+ (set! maxf #t))
+ (let ((type (if (symbol? element)
+ 'eq?
+ (car (->eqf (->simple-type element))))))
+ (if (or (memq maxf '(#f eq?))
+ (memq type '(#t equal?)))
+ (set! maxf type)))))))
+ ;; else (list ...)
+ (do ((p keys (cdr p)))
+ ((or (null? p)
+ (memq maxf '(equal? #t))))
+ (let ((element (car p)))
+ (if (symbol? element)
+ (set! maxf #t)
+ (let ((type (car (eqf element env))))
+ (if (or (memq maxf '(#f eq?))
+ (memq type '(#t equal?)))
+ (set! maxf type)))))))
+ (case maxf
+ ((eq?)
+ (if (not (memq head '(memq assq)))
+ (lint-format "~A could be ~A in ~A" caller
+ head
+ (if (memq head '(memv member)) 'memq 'assq)
+ form)))
+ ((eqv?)
+ (if (not (memq head '(memv assv)))
+ (lint-format "~A ~Aould be ~A in ~A" caller
+ head
+ (if (memq head '(memq assq)) "sh" "c")
+ (if (memq head '(memq member)) 'memv 'assv)
+ form)))
+ ((equal? #t)
+ (if (not (memq head '(member assoc)))
+ (lint-format "~A should be ~A in ~A" caller
+ head
+ (if (memq head '(memq memv)) 'member 'assoc)
+ form)))))))
+ ;; --------------------------------
+
+ (if (and (= (length elements) 2)
+ (memq #t elements)
+ (memq #f elements))
+ (lint-format "perhaps ~A" caller (lists->string form `(boolean? ,selector))))))
+ ;; not (memv x '(0 0.0)) -> (zero? x) because x might not be a number
+
+ (let ((memx (memq head '(memq memv member))))
+ (case (car items)
+ ((map)
+ (when (and memx (= (length items) 3))
+ (let ((mapf (cadr items))
+ (map-items (caddr items)))
+ (cond ((eq? mapf 'car)
+ (lint-format "perhaps use assoc: ~A" caller
+ (lists->string form `(,(case current-eqf ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc))
+ ,selector ,map-items))))
+ ((eq? selector #t)
+ (if (eq? mapf 'null?)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(memq () ,map-items)))
+ (let ((b (if (eq? mapf 'b) 'c 'b)))
+ (lint-format "perhaps avoid 'map: ~A" caller
+ (lists->string form `(member #t ,map-items (lambda (a ,b) (,mapf ,b))))))))
+
+ ((and (pair? selector)
+ (eq? (car selector) 'string->symbol) ; this could be extended, but it doesn't happen
+ (eq? mapf 'string->symbol)
+ (not (and (pair? map-items)
+ (eq? (car map-items) 'quote))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(member ,(cadr selector) ,map-items string=?))))
+ (else
+ (let ((b (if (eq? mapf 'b) 'c 'b))) ; a below can't collide because eqf won't return 'a
+ (lint-format "perhaps avoid 'map: ~A" caller
+ (lists->string form `(member ,selector ,map-items
+ (lambda (a ,b) (,current-eqf a (,mapf ,b))))))))))))
+ ((string->list) ; (memv c (string->list s)) -> (char-position c s)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(char-position ,(cadr form) ,@(cdr items)))))
+
+ ((cons)
+ (if (not (pair? selector))
+ (lint-format "perhaps avoid 'cons: ~A" caller
+ (lists->string form `(or (,current-eqf ,selector ,(cadr items))
+ (,head ,selector ,(caddr items)))))))
+ ((append)
+ (if (and (not (pair? selector))
+ (= (length items) 3)
+ (pair? (cadr items))
+ (eq? (caadr items) 'list)
+ (null? (cddadr items)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(or (,current-eqf ,selector ,(cadadr items))
+ (,head ,selector ,(caddr items)))))))))))))
+ (when (and (memq head '(memq memv))
+ (pair? items)
+ (eq? (car items) 'quote)
+ (pair? (cadr items)))
+ (let ((nitems (length (cadr items))))
+
+ (if (pair? selector) ; (memv (string-ref x 0) '(+ -)) -> #f etc
+ (let ((sig (arg-signature (car selector) env)))
+ (if (and (pair? sig)
+ (symbol? (car sig))
+ (not (eq? (car sig) 'values)))
+ (let ((vals (map (lambda (item)
+ (if ((symbol->value (car sig)) item) item (values)))
+ (cadr items))))
+ (if (not (= (length vals) nitems))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (and (pair? vals)
+ `(,head ,selector ',vals)))))))))
+ (if (> nitems 20)
+ (lint-format "perhaps use a hash-table here, rather than ~A" caller (truncated-list->string form)))
+
+ (let ((bad (find-if (lambda (x)
+ (not (or (symbol? x)
+ (char? x)
+ (number? x)
+ (procedure? x) ; (memq abs '(1 #_abs 2)) !
+ (memq x '(#f #t () #<unspecified> #<undefined> #<eof>)))))
+ (cadr items))))
+ (if bad
+ (lint-format (if (and (pair? bad)
+ (eq? (car bad) 'unquote))
+ (values "stray comma? ~A" caller)
+ (values "pointless list member: ~S in ~A" caller bad))
+ ;; quoted item here is caught above
+ form))))))))
+
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-memx))
+ '(memq assq memv assv member assoc)))
+
+ ;; ---------------- car, cdr, etc ----------------
+ (let ()
+ (define (sp-crx caller head form env)
+ (if (not (= line-number last-simplify-cxr-line-number))
+ ((lambda* (cxr arg)
+ (when cxr
+ (set! last-simplify-cxr-line-number line-number)
+ (cond ((< (length cxr) 5)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(symbol "c" cxr "r") ,arg))))
+
+ ;; if it's car|cdr followed by cdr's, use list-ref|tail
+ ((not (char-position #\a cxr))
+ (lint-format "perhaps ~A" caller (lists->string form `(list-tail ,arg ,(length cxr)))))
+
+ ((not (char-position #\a (substring cxr 1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(list-ref ,arg ,(- (length cxr) 1)))))
+
+ (else (set! last-simplify-cxr-line-number -1)))))
+ (combine-cxrs form)))
+
+ (when (pair? (cadr form))
+ (when (eq? head 'car)
+ (if (eq? (caadr form) 'list-tail) ; (car (list-tail x y)) -> (list-ref x y)
+ (lint-format "perhaps ~A" caller (lists->string form `(list-ref ,(cadadr form) ,(caddr (cadr form)))))
+ (if (and (memq (caadr form) '(memq memv member assq assv assoc))
+ (pair? (cdadr form))) ; (car (memq...))
+ (lint-format "~A is ~A, or an error" caller (truncated-list->string form) (cadadr form)))))
+
+ (if (and (memq head '(car cdr))
+ (eq? (caadr form) 'cons))
+ (lint-format "(~A~A) is the same as ~A"
+ caller head
+ (truncated-list->string (cadr form))
+ (if (eq? head 'car)
+ (truncated-list->string (cadadr form))
+ (truncated-list->string (caddr (cadr form))))))
+
+ (when (memq head '(car cadr caddr cadddr))
+ (if (memq (caadr form) '(string->list vector->list)) ; (car (string->list x)) -> (string-ref x 0)
+ (lint-format "perhaps ~A" caller (lists->string form `(,(if (eq? (caadr form) 'string->list) 'string-ref 'vector-ref)
+ ,(cadadr form)
+ ,(case head ((car) 0) ((cadr) 1) ((caddr) 2) (else 3)))))
+ (if (and (memq (caadr form) '(reverse reverse!))
+ (symbol? (cadadr form)))
+ (lint-format "perhaps ~A" caller ; (car (reverse x)) -> (list-ref x (- (length x) 1))
+ (lists->string form `(list-ref ,(cadadr form)
+ (- (length ,(cadadr form))
+ ,(case head ((car) 1) ((cadr) 2) ((caddr) 3) (else 4)))))))))))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-crx))
+ combinable-cxrs))
+
+ ;; ---------------- set-car! ----------------
+ (let ()
+ (define (sp-set-car! caller head form env)
+ (when (= (length form) 3)
+ (let ((target (cadr form)))
+ (if (pair? target)
+ (case (car target)
+
+ ((list-tail) ; (set-car! (list-tail x y) z) -> (list-set! x y z)
+ (lint-format "perhaps ~A" caller (lists->string form `(list-set! ,(cadr target) ,(caddr target) ,(caddr form)))))
+
+ ((cdr cddr cdddr cddddr)
+ (set! last-simplify-cxr-line-number line-number)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? (cadr target))
+ (memq (caadr target) '(cdr cddr cdddr cddddr)))
+ ;; (set-car! (cdr (cddr x)) y) -> (list-set! x 3 y)
+ `(list-set! ,(cadadr target)
+ ,(+ (cdr-count (car target)) (cdr-count (caadr target)))
+ ,(caddr form))
+ ;; (set-car! (cdr x) y) -> (list-set! x 1 y)
+ `(list-set! ,(cadr target)
+ ,(cdr-count (car target))
+ ,(caddr form)))))))))))
+ (hash-table-set! h 'set-car! sp-set-car!))
+
+ ;; ---------------- not and or ----------------
+ (let ()
+ (define (sp-not caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'not))
+ (lint-format "if you want a boolean, (not (not ~A)) -> (and ~A #t)" 'paranoia
+ (truncated-list->string (cadadr form))
+ (truncated-list->string (cadadr form))))
+ (if (not (= line-number last-simplify-boolean-line-number))
+ (let ((val (simplify-boolean form () () env)))
+ (set! last-simplify-boolean-line-number line-number)
+ (if (not (equal? form val))
+ (lint-format "perhaps ~A" caller (lists->string form val))))))
+ (hash-table-set! h 'not sp-not))
+
+ (let ()
+ (define (sp-and caller head form env)
+ (if (not (= line-number last-simplify-boolean-line-number))
+ (let ((val (simplify-boolean form () () env)))
+ (set! last-simplify-boolean-line-number line-number)
+ (if (not (equal? form val))
+ (lint-format "perhaps ~A" caller (lists->string form val)))))
+ (if (pair? (cdr form))
+ (do ((p (cdr form) (cdr p)))
+ ((null? (cdr p)))
+ (if (and (pair? (car p))
+ (eq? (caar p) 'if)
+ (= (length (car p)) 3))
+ (lint-format "one-armed if might cause confusion here: ~A" caller form)))))
+ (hash-table-set! h 'and sp-and)
+ (hash-table-set! h 'or sp-and))
+
+ ;; ---------------- = ----------------
+ (let ()
+ (define (sp-= caller head form env)
+ (let ((len (length form)))
+ (if (and (> len 2)
+ (any-real? (cdr form)))
+ (lint-format "= can be troublesome with floats: ~A" caller (truncated-list->string form)))
+
+ (let ((cleared-form (cons = (remove-if (lambda (x) (not (number? x))) (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+
+ (when (= len 3)
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+ (let ((var (or (and (memv arg1 '(0 1))
+ (pair? arg2)
+ (eq? (car arg2) 'length)
+ (cadr arg2))
+ (and (memv arg2 '(0 1))
+ (pair? arg1)
+ (eq? (car arg1) 'length)
+ (cadr arg1)))))
+ ;; we never seem to have var-member/initial-value/history here to distinguish types
+ (if var
+ (if (or (eqv? arg1 0)
+ (eqv? arg2 0))
+ (lint-format "perhaps (assuming ~A is a list), ~A" caller var
+ (lists->string form `(null? ,var)))
+ (if (symbol? var)
+ (lint-format "perhaps (assuming ~A is a list), ~A" caller var
+ (lists->string form `(and (pair? ,var) (null? (cdr ,var))))))))))
+ (unrelop caller '= form))
+ (check-char-cmp caller '= form)))
+ (hash-table-set! h '= sp-=))
+
+ ;; ---------------- < > <= >= ----------------
+ (let ()
+ (define (sp-< caller head form env)
+ (let ((cleared-form (cons head ; keep operator
+ (remove-if (lambda (x)
+ (not (number? x)))
+ (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+
+ (if (= (length form) 3)
+ (unrelop caller head form)
+ (when (> (length form) 3)
+ (if (and (memq head '(< >))
+ (repeated-member? (cdr form) env))
+ (lint-format "perhaps ~A" caller (truncated-lists->string form #f))
+ (if (and (memq head '(<= >=))
+ (repeated-member? (cdr form) env))
+ (let ((last-arg (cadr form))
+ (new-args (list (cadr form))))
+ (do ((lst (cddr form) (cdr lst)))
+ ((null? lst)
+ (if (repeated-member? new-args env)
+ (lint-format "perhaps ~A" caller (truncated-lists->string form `(= ,@(lint-remove-duplicates (reverse new-args) env))))
+ (if (< (length new-args) (length (cdr form)))
+ (lint-format "perhaps ~A" caller
+ (truncated-lists->string form (or (null? (cdr new-args))
+ `(= ,@(reverse new-args))))))))
+ (unless (equal? (car lst) last-arg)
+ (set! last-arg (car lst))
+ (set! new-args (cons last-arg new-args)))))))))
+
+ (when (= (length form) 3)
+ (cond ((and (real? (cadr form))
+ (or (< (cadr form) 0)
+ (and (zero? (cadr form))
+ (eq? head '>)))
+ (pair? (caddr form))
+ (hash-table-ref non-negative-ops (caaddr form)))
+ (lint-format "~A can't be negative: ~A" caller (caaddr form) (truncated-list->string form)))
+
+ ((and (real? (caddr form))
+ (or (< (caddr form) 0)
+ (and (zero? (caddr form))
+ (eq? head '<)))
+ (pair? (cadr form))
+ (hash-table-ref non-negative-ops (caadr form)))
+ (lint-format "~A can't be negative: ~A" caller (caadr form) (truncated-list->string form)))
+
+ ((and (pair? (cadr form))
+ (eq? (caadr form) 'length))
+ (let ((arg (cadadr form)))
+ (when (symbol? arg)
+ (if (eqv? (caddr form) 0)
+ (lint-format "perhaps~A ~A" caller
+ (if (eq? head '<) "" (format #f " (assuming ~A is a proper list)," arg))
+ (lists->string form
+ (case head
+ ((<) `(and (pair? ,arg) (not (proper-list? ,arg))))
+ ((<=) `(null? ,arg))
+ ((>) `(pair? ,arg))
+ ((>=) `(list? ,arg)))))
+ (if (and (eqv? (caddr form) 1)
+ (not (eq? head '>)))
+ (lint-format "perhaps (assuming ~A is a proper list), ~A" caller arg
+ (lists->string form
+ (case head
+ ((<) `(null? ,arg))
+ ((<=) `(or (null? ,arg) (null? (cdr ,arg))))
+ ((>) `(and (pair? ,arg) (pair? (cdr ,arg))))
+ ((>=) `(pair? ,arg))))))))))
+ ((and (pair? (caddr form))
+ (eq? (caaddr form) 'length))
+ (let ((arg (cadr (caddr form))))
+ (when (symbol? arg)
+ (if (eqv? (cadr form) 0)
+ (lint-format "perhaps~A ~A" caller
+ (if (eq? head '>) "" (format #f " (assuming ~A is a proper list)," arg))
+ (lists->string form
+ (case head
+ ((<) `(pair? ,arg))
+ ((<=) `(list? ,arg))
+ ((>) `(and (pair? ,arg) (not (proper-list? ,arg))))
+ ((>=) `(null? ,arg)))))
+ (if (and (eqv? (cadr form) 1)
+ (not (eq? head '<)))
+ (lint-format "perhaps (assuming ~A is a proper list), ~A" caller arg
+ (lists->string form
+ (case head
+ ((<) `(and (pair? ,arg) (pair? (cdr ,arg))))
+ ((<=) `(pair? ,arg))
+ ((>) `(null? ,arg))
+ ((>=) `(or (null? ,arg) (null? (cdr ,arg))))))))))))
+
+ ((or (and (eqv? (cadr form) 0) ; (> (numerator x) 0) -> (> x 0)
+ (pair? (caddr form))
+ (eq? (caaddr form) 'numerator))
+ (and (eqv? (caddr form) 0)
+ (pair? (cadr form))
+ (eq? (caadr form) 'numerator)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eqv? (cadr form) 0)
+ `(,head ,(cadr form) ,(cadr (caddr form)))
+ `(,head ,(cadadr form) ,(caddr form))))))))
+ (check-char-cmp caller head form))
+ ;; could change (> x 0) to (positive? x) and so on, but the former is clear and ubiquitous
+
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-<))
+ '(< > <= >=))) ; '= handled above
+
+ ;; ---------------- char< char> etc ----------------
+ (let ()
+ (define (sp-char< caller head form env)
+ (let ((cleared-form (cons head ; keep operator
+ (remove-if (lambda (x)
+ (not (char? x)))
+ (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+ (if (and (eq? head 'char-ci=?) ; (char-ci=? x #\return)
+ (pair? (cdr form))
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (or (and (char? (cadr form))
+ (char=? (cadr form) (other-case (cadr form))))
+ (and (char? (caddr form))
+ (char=? (caddr form) (other-case (caddr form))))))
+ (lint-format "char-ci=? could be char=? here: ~A" caller form)))
+
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-char<))
+ '(char<? char>? char<=? char>=? char=? char-ci<? char-ci>? char-ci<=? char-ci>=? char-ci=?)))
+
+
+ ;; ---------------- string< string> etc ----------------
+ (let ()
+ (define (sp-string< caller head form env)
+ (let ((cleared-form (cons head ; keep operator
+ (remove-if (lambda (x)
+ (not (string? x)))
+ (cdr form)))))
+ (if (and (> (length cleared-form) 2)
+ (not (checked-eval cleared-form)))
+ (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
+
+ (when (and (eq? head 'string=?) ; (string=? (symbol->string a) (symbol->string b)) -> (eq? a b)
+ (= (length form) 3))
+ (if (and (pair? (cadr form))
+ (eq? (caadr form) 'symbol->string)
+ (pair? (caddr form))
+ (eq? (caaddr form) 'symbol->string))
+ (lint-format "perhaps ~A" caller (lists->string form `(eq? ,(cadadr form) ,(cadr (caddr form)))))
+ (let ((s1 #f)
+ (s2 #f))
+ (if (and (string? (cadr form))
+ (= (length (cadr form)) 1))
+ (begin
+ (set! s1 (cadr form))
+ (set! s2 (caddr form)))
+ (if (and (string? (caddr form))
+ (= (length (caddr form)) 1))
+ (begin
+ (set! s1 (caddr form))
+ (set! s2 (cadr form)))))
+ (if (and s1 ; (string=? (substring refdes-alias 0 1) "S")
+ (pair? s2)
+ (eq? (car s2) 'substring)
+ (= (length s2) 4)
+ (eqv? (list-ref s2 2) 0)
+ (eqv? (list-ref s2 3) 1))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(char=? (string-ref ,(cadr s2) 0) ,(string-ref s1 0))))))))
+
+ (if (every? (lambda (a)
+ (or (and (string? a)
+ (= (length a) 1))
+ (and (pair? a)
+ (eq? (car a) 'string))))
+ (cdr form))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,(symbol "char" (substring (symbol->string head) 6))
+ ,@(map (lambda (a)
+ (if (string? a)
+ (string-ref a 0)
+ (cadr a)))
+ (cdr form)))))))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-string<))
+ '(string<? string>? string<=? string>=? string=? string-ci<? string-ci>? string-ci<=? string-ci>=? string-ci=?)))
+
+ ;; ---------------- length ----------------
+ (let ()
+ (define (sp-length caller head form env)
+ (when (pair? (cdr form))
+ (if (pair? (cadr form))
+ (let ((arg (cadr form)))
+ (case (car arg)
+ ((string->list vector->list)
+ (if (null? (cddr arg)) ; string->list has start:end etc
+ (lint-format "perhaps ~A" caller (lists->string form `(length ,(cadr arg))))
+ (if (pair? (cdddr arg))
+ (if (and (integer? (cadddr arg))
+ (integer? (caddr arg)))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (max 0 (- (cadddr arg) (caddr arg))))
+ (lint-format "perhaps ~A" caller (lists->string form `(- ,(cadddr arg) ,(caddr arg)))))
+ (lint-format "perhaps ~A" caller (lists->string form `(- (length ,(cadr arg)) ,(caddr arg)))))))
- (if (and (symbol? (car selector-eqf))
- (not (eq? (car selector-eqf) current-eqf)))
- (lint-format "~A: perhaps ~A -> ~A" caller (truncated-list->string form) head
- (if (memq head '(memq memv member))
- (case (car selector-eqf) ((eq?) 'memq) ((eqv?) 'memv) ((equal?) 'member))
- (case (car selector-eqf) ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc)))))
+ ((reverse reverse! list->vector list->string let->list)
+ (lint-format "perhaps ~A" caller (lists->string form `(length ,(cadr arg)))))
- (if (and (pair? items)
- (eq? (car items) 'list)
- (every? code-constant? (cdr items)))
- (lint-format "perhaps ~A -> '~A" caller (truncated-list->string items)
- (truncated-list->string (map unquoted (cdr items)))))
+ ((cons)
+ (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(caddr arg)) 1))))
- (when (pair? items)
- (let ((memx (memq head '(memq memv member))))
- (case (car items)
- ((map)
- (when (and memx (= (length items) 3))
- (let ((mapf (cadr items))
- (map-items (caddr items)))
- (cond ((eq? mapf 'car)
- (lint-format "perhaps use assoc: ~A" caller
- (lists->string form `(,(case current-eqf ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc))
- ,selector ,map-items))))
- ((eq? selector #t)
- (if (eq? mapf 'null?)
- (lint-format "perhaps ~A" caller
- (lists->string form `(memq () ,map-items)))
- (let ((b (if (eq? mapf 'b) 'c 'b)))
- (lint-format "perhaps avoid 'map: ~A" caller
- (lists->string form `(member #t ,map-items (lambda (a ,b) (,mapf ,b))))))))
-
- ((and (pair? selector)
- (eq? (car selector) 'string->symbol) ; this could be extended, but it doesn't happen
- (eq? mapf 'string->symbol)
- (not (and (pair? map-items)
- (eq? (car map-items) 'quote))))
- (lint-format "perhaps ~A" caller
- (lists->string form `(member ,(cadr selector) ,map-items string=?))))
- (else
- (let ((b (if (eq? mapf 'b) 'c 'b))) ; a below can't collide because eqf won't return 'a
- (lint-format "perhaps avoid 'map: ~A" caller
- (lists->string form `(member ,selector ,map-items
- (lambda (a ,b) (,current-eqf a (,mapf ,b))))))))))))
- ((cons)
- (if (not (pair? selector))
- (lint-format "perhaps avoid 'cons: ~A" caller
- (lists->string form `(or (,current-eqf ,selector ,(cadr items))
- (,head ,selector ,(caddr items)))))))
- ((append)
- (if (and (not (pair? selector))
- (= (length items) 3)
- (pair? (cadr items))
- (eq? (caadr items) 'list)
- (null? (cddadr items)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(or (,current-eqf ,selector ,(cadadr items))
- (,head ,selector ,(caddr items)))))))))))))
-
- (when (and (eq? (->lint-type (cadr form)) 'char?)
- (pair? (caddr form))
- (eq? (caaddr form) 'string->list)
- (null? (cdddr form)))
+ ((make-list)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))
+
+ ((list)
+ (lint-format "perhaps ~A" caller (lists->string form (- (length arg) 1))))
+
+ ((append)
+ (if (= (length arg) 3)
+ (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(cadr arg)) (length ,(caddr arg)))))))
+
+ ((quote)
+ (if (list? (cadr arg))
+ (lint-format "perhaps ~A" caller (lists->string form (length (cadr arg))))))))
+ ;; not pair cadr
+ (if (code-constant? (cadr form))
+ (lint-format "perhaps ~A -> ~A" caller
+ (truncated-list->string form)
+ (length ((if (and (pair? (cadr form))
+ (eq? (caadr form) 'quote))
+ cadadr cadr)
+ form)))))))
+ (hash-table-set! h 'length sp-length))
+
+ ;; ---------------- zero? positive? negative? ----------------
+ (let ()
+ (define (sp-zero? caller head form env)
+ (when (pair? (cdr form))
+ (let ((arg (cadr form)))
+ (when (pair? arg)
+
+ (if (and (eq? head 'negative?)
+ (hash-table-ref non-negative-ops (car arg)))
+ (lint-format "~A can't be negative: ~A" caller head (truncated-list->string form)))
+
+ (case (car arg)
+ ((-)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((op '((zero? = zero?) (positive? > negative?) (negative? < positive?))))
+ (if (null? (cddr arg))
+ `(,(caddr (assq head op)) ,(cadr arg))
+ (if (null? (cdddr arg))
+ `(,(cadr (assq head op)) ,(cadr arg) ,(caddr arg))
+ `(,(cadr (assq head op)) ,(cadr arg) (+ ,@(cddr arg)))))))))
+
+ ((numerator) ; (negative? (numerator x)) -> (negative? x)
+ (lint-format "perhaps ~A" caller (lists->string form `(,head ,(cadadr form)))))
+
+ ((denominator) ; (zero? (denominator x)) -> error
+ (if (eq? head 'zero)
+ (lint-format "denominator can't be zero: ~A" caller form)))
+
+ ((length)
+ (if (eq? head 'zero?)
+ (lint-format "perhaps (assuming ~A is list) use null? instead of length: ~A" caller (cadr arg)
+ (lists->string form `(null? ,(cadr arg)))))))))))
+ ;; (zero? (logand...)) is nearly always preceded by not and handled elsewhere
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-zero?))
+ '(zero? positive? negative?)))
+
+ ;; ---------------- / ----------------
+ (let ()
+ (define (sp-/ caller head form env)
+ (when (pair? (cdr form))
+ (if (and (null? (cddr form))
+ (number? (cadr form))
+ (zero? (cadr form)))
+ (lint-format "attempt to invert zero: ~A" caller (truncated-list->string form))
+ (if (and (pair? (cddr form))
+ (memv 0 (cddr form)))
+ (lint-format "attempt to divide by 0: ~A" caller (truncated-list->string form))))))
+ (hash-table-set! h '/ sp-/))
+
+ ;; ---------------- copy ----------------
+ (let ()
+ (define (sp-copy caller head form env)
+ (cond ((and (pair? (cdr form))
+ (or (number? (cadr form))
+ (boolean? (cadr form))
+ (char? (cadr form))
+ (and (pair? (cadr form))
+ (memq (caadr form) '(copy string-copy))) ; or any maker?
+ (and (pair? (cddr form))
+ (equal? (cadr form) (caddr form)))))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form)))
+
+ ((and (pair? (cdr form))
+ (equal? (cadr form) '(owlet)))
+ (lint-format "~A could be (owlet): owlet is copied internally" caller form))
+
+ ((= (length form) 5)
+ (check-start-and-end caller 'copy (cdddr form) form env))))
+ (hash-table-set! h 'copy sp-copy))
+
+ ;; ---------------- string-copy ----------------
+ (hash-table-set!
+ h 'string-copy
+ (lambda (caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(copy string-copy string make-string string-upcase string-downcase
+ string-append list->string symbol->string number->string)))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form)))))
+
+ ;; ---------------- string ----------------
+ (let ()
+ (define (sp-string caller head form env)
+ (if (every? (lambda (x)
+ (and (char? x)
+ (char<=? #\space x #\~))) ; #\0xx chars here look dumb
+ (cdr form))
+ (lint-format "~A could be ~S" caller (truncated-list->string form) (apply string (cdr form)))
+ (if (and (pair? (cdr form)) ; (string (string-ref x 0)) -> (substring x 0 1)
+ (pair? (cadr form)))
+ (if (and (eq? (caadr form) 'string-ref)
+ (null? (cddr form)))
+ (let ((arg (cadr form)))
+ (if (integer? (caddr arg))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(substring ,(cadr arg) ,(caddr arg) ,(+ 1 (caddr arg)))))))
+ (if (and (not (null? (cddr form)))
+ (memq (caadr form) '(char-upcase char-downcase))
+ (every? (lambda (p)
+ (eq? (caadr form) (car p)))
+ (cddr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(if (eq? (caadr form) 'char-upcase) 'string-upcase 'string-downcase)
+ (string ,@(map cadr (cdr form)))))))))))
+ (hash-table-set! h 'string sp-string))
+
+ ;; ---------------- string? ----------------
+ (let ()
+ (define (sp-string? caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(format number->string)))
+ (if (eq? (caadr form) 'format)
+ (lint-format "format returns either #f or a string, so ~A" caller (lists->string form (cadr form)))
+ (lint-format "number->string always returns a string, so ~A" caller (lists->string form #t)))
+ (check-boolean-affinity caller form env)))
+ (hash-table-set! h 'string? sp-string?))
+
+ ;; ---------------- number? ----------------
+ (let ()
+ (define (sp-number? caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'string->number))
+ (lint-format "string->number returns either #f or a number, so ~A" caller (lists->string form (cadr form)))
+ (check-boolean-affinity caller form env)))
+ (hash-table-set! h 'number? sp-number?))
+
+ ;; ---------------- symbol? etc ----------------
+ (let ()
+ (define (sp-symbol? caller head form env)
+ (check-boolean-affinity caller form env))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-symbol?))
+ '(symbol? rational? real? complex? float? keyword? gensym? byte-vector? proper-list?
+ char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? c-object?
+ output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer?)))
+
+ ;; ---------------- pair? list? ----------------
+ (let ()
+ (define (sp-pair? caller head form env)
+ (check-boolean-affinity caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(memq memv member assq assv assoc procedure-signature)))
+ (lint-format "~A returns either #f or a pair, so ~A" caller (caadr form)
+ (lists->string form (cadr form)))))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-pair?))
+ '(pair? list?)))
+
+ ;; ---------------- integer? ----------------
+ (let ()
+ (define (sp-integer? caller head form env)
+ (check-boolean-affinity caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(char-position string-position)))
+ (lint-format "~A returns either #f or an integer, so ~A" caller (caadr form)
+ (lists->string form (cadr form)))))
+ (hash-table-set! h 'integer? sp-integer?))
+
+ ;; ---------------- null? ----------------
+ (let ()
+ (define (sp-null? caller head form env)
+ (check-boolean-affinity caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form))
+ (memq (caadr form) '(vector->list string->list let->list)))
(lint-format "perhaps ~A" caller
- (lists->string form `(char-position ,(cadr form) ,@(cdaddr form)))))
-
- (when (and (memq head '(memq memv))
- (pair? items)
- (eq? (car items) 'quote)
- (pair? (cadr items)))
- (if (> (length items) 20)
- (lint-format "perhaps use a hash-table here, rather than ~A" caller (truncated-list->string form)))
-
- (let ((bad (find-if (lambda (x)
- (not (or (symbol? x)
- (char? x)
- (number? x)
- (procedure? x) ; (memq abs '(1 #_abs 2)) !
- (memq x '(#f #t () #<unspecified> #<undefined> #<eof>)))))
- (cadr items))))
- (if bad
- (lint-format (cond ((not (pair? bad))
- (values "pointless list member: ~S in ~A" caller bad))
- ((eq? (car bad) 'quote)
- (values "stray quote? ~A" caller))
- ((eq? (car bad) 'unquote)
- (values "stray comma? ~A" caller))
- (else (values "pointless list member: ~S in ~A" caller bad)))
- form)))))))
-
- ;; ----------------
- ((car cdr
- caar cadr cddr cdar
- caaar caadr caddr cdddr cdaar cddar cadar cdadr
- cadddr cddddr)
- ;; caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar
-
- (if (not (= line-number last-simplify-cxr-line-number))
- ((lambda* (cxr arg)
- (when cxr
- (set! last-simplify-cxr-line-number line-number)
- (cond ((< (length cxr) 5)
- (lint-format "perhaps ~A" caller
- (lists->string form `(,(string->symbol (string-append "c" cxr "r")) ,arg))))
+ (lists->string form `(zero? (length ,(cadadr form)))))))
+ (hash-table-set! h 'null? sp-null?))
+
+ ;; ---------------- string-ref ----------------
+ (hash-table-set!
+ h 'string-ref
+ (lambda (caller head form env)
+ (when (and (= (length form) 3)
+ (pair? (cadr form)))
+ (let ((target (cadr form)))
+ (case (car target)
+ ((substring)
+ (if (= (length target) 3)
+ (lint-format "perhaps ~A" caller (lists->string form `(string-ref ,(cadr target) (+ ,(caddr form) ,(caddr target)))))))
+
+ ((symbol->string)
+ (if (and (integer? (caddr form))
+ (pair? (cadr target))
+ (eq? (caadr target) 'quote)
+ (symbol? (cadadr target)))
+ (lint-format "perhaps ~A" caller (lists->string form (string-ref (symbol->string (cadadr target)) (caddr form))))))
+
+ ((make-string)
+ (if (and (integer? (cadr target))
+ (integer? (caddr form))
+ (> (cadr target) (caddr form)))
+ (lint-format "perhaps ~A" caller (lists->string form (if (= (length target) 3) (caddr target) #\space))))))))))
+
+ ;; ---------------- vector-ref etc ----------------
+ (let ()
+ (define (sp-vector-ref caller head form env)
+ (unless (= line-number last-checker-line-number)
+ (when (= (length form) 3)
+ (let ((seq (cadr form)))
+ (when (pair? seq)
+ (if (and (memq (car seq) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref))
+ (= (length seq) 3)) ; (vector-ref (vector-ref x i) j) -> (x i j)
+ (let ((seq1 (cadr seq))) ; x
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? seq1) ; (vector-ref (vector-ref (vector-ref x i) j) k) -> (x i j k)
+ (memq (car seq1) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref))
+ (= (length seq1) 3))
+ `(,(cadr seq1) ,(caddr seq1) ,(caddr seq) ,(caddr form))
+ `(,seq1 ,(caddr seq) ,(caddr form))))))
+ (if (memq (car seq) '(make-vector make-list vector list
+ make-float-vector make-int-vector float-vector int-vector
+ make-hash-table hash-table hash-table*
+ inlet))
+ (lint-format "this doesn't make much sense: ~A" caller form)))
+ (if (and (eq? head 'list-ref)
+ (eq? (car seq) 'quote)
+ (proper-list? (cadr seq)))
+ (lint-format "perhaps use a vector: ~A" caller
+ (lists->string form `(vector-ref ,(apply vector (cadr seq)) ,(caddr form))))))))
+ (set! last-checker-line-number line-number)))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-vector-ref))
+ '(vector-ref list-ref hash-table-ref let-ref int-vector-ref float-vector-ref)))
+
+
+ ;; ---------------- vector-set! etc ----------------
+ (let ()
+ (define (sp-vector-set! caller head form env)
+ (when (= (length form) 4)
+ (let ((target (cadr form))
+ (index (caddr form))
+ (val (cadddr form)))
+
+ (cond ((and (pair? val) ; (vector-set! x 0 (vector-ref x 0))
+ (= (length val) 3)
+ (eq? target (cadr val))
+ (equal? index (caddr val))
+ (memq (car val) '(vector-ref list-ref hash-table-ref string-ref let-ref float-vector-ref int-vector-ref)))
+ (lint-format "redundant ~A: ~A" caller head (truncated-list->string form)))
+
+ ((and (pair? target) ; (vector-set! (vector-ref x 0) 1 2) -- vector within vector
+ (not (eq? head 'string-set!))
+ (memq (car target) '(vector-ref list-ref hash-table-ref let-ref float-vector-ref int-vector-ref)))
+ (lint-format "perhaps ~A" caller (lists->string form `(set! (,@(cdr target) ,index) ,val))))
+
+ ((and (pair? target) ; (vector-set! (make-vector 3) 1 1) -- does this ever happen?
+ (memq (car target) '(make-vector vector make-string string make-list list append cons vector-append copy inlet sublet)))
+ (lint-format "~A is simply discarded; perhaps ~A" caller
+ (truncated-list->string target)
+ (lists->string form val)))
+
+ ((code-constant? target) ; (vector-set! #(0 1 2) 1 3)??
+ (lint-format "~A is a constant that is discarded; perhaps ~A" caller target (lists->string form val)))))))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-vector-set!))
+ '(vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! string-set! let-set!)))
+
+ ;; ---------------- object->string ----------------
+ (hash-table-set!
+ h 'object->string
+ (lambda (caller head form env)
+ (when (pair? (cdr form))
+ (if (and (pair? (cadr form))
+ (eq? (caadr form) 'object->string))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))
+ (if (pair? (cddr form))
+ (let ((arg2 (caddr form)))
+ (if (or (and (keyword? arg2)
+ (not (eq? arg2 :readable)))
+ (and (code-constant? arg2)
+ (not (boolean? arg2))))
+ (lint-format "bad second argument: ~A" caller arg2))))))))
+
+ ;; ---------------- display ----------------
+ (hash-table-set!
+ h 'display
+ (lambda (caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form)))
+ (let ((arg (cadr form))
+ (port (if (pair? (cddr form))
+ (caddr form)
+ ())))
+ (cond ((and (string? arg)
+ (or (string-position "ERROR" arg)
+ (string-position "WARNING" arg)))
+ (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))
+
+ ((and (eq? (car arg) 'format)
+ (pair? (cdr arg))
+ (not (cadr arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(format ,port ,@(cddr arg)))))
+
+ ((and (eq? (car arg) 'apply)
+ (pair? (cdr arg))
+ (eq? (cadr arg) 'format)
+ (pair? (cddr arg))
+ (not (caddr arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(apply format ,port ,@(cdddr arg))))))))))
+
+ ;; ---------------- make-vector etc ----------------
+ (let ()
+ (define (sp-make-vector caller head form env)
+ ;; type of initial value (for make-float|int-vector) is checked elsewhere
+ (if (and (= (length form) 4)
+ (eq? head 'make-vector))
+ (lint-format "make-vector no longer has a fourth argument: ~A~%" caller form))
+
+ (if (>= (length form) 3)
+ (case (caddr form)
+ ((#<unspecified>)
+ (if (eq? head 'make-vector)
+ (lint-format "#<unspecified> is the default initial value in ~A" caller form)))
+ ((0)
+ (if (not (eq? head 'make-vector))
+ (lint-format "0 is the default initial value in ~A" caller form)))
+ ((0.0)
+ (if (eq? head 'make-float-vector)
+ (lint-format "0.0 is the default initial value in ~A" caller form)))))
+
+ (when (and (pair? (cdr form))
+ (integer? (cadr form))
+ (zero? (cadr form)))
+ (if (pair? (cddr form))
+ (lint-format "initial value is pointless here: ~A" caller form))
+ (lint-format "perhaps ~A" caller (lists->string form #()))))
+
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-make-vector))
+ '(make-vector make-int-vector make-float-vector)))
+
+ ;; ---------------- make-string make-byte-vector ----------------
+ (let ()
+ (define (sp-make-string caller head form env)
+ (when (and (pair? (cdr form))
+ (integer? (cadr form))
+ (zero? (cadr form)))
+ (if (pair? (cddr form))
+ (lint-format "initial value is pointless here: ~A" caller form))
+ (lint-format "perhaps ~A" caller (lists->string form "")))) ; #u8() but (equal? #u8() "") -> #t so lint combines these clauses!
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-make-string))
+ '(make-string make-byte-vector)))
+
+ ;; ---------------- make-list ----------------
+ (let ()
+ (define (sp-make-list caller head form env)
+ (when (and (pair? (cdr form))
+ (integer? (cadr form))
+ (zero? (cadr form)))
+ (if (pair? (cddr form))
+ (lint-format "initial value is pointless here: ~A" caller form))
+ (lint-format "perhaps ~A" caller (lists->string form ()))))
+ (hash-table-set! h 'make-list sp-make-list))
+
+ ;; ---------------- reverse string->list etc ----------------
+ (let ()
+ (define (sp-reverse caller head form env)
+ ;; not string->number -- no point in copying a number and it's caught below
+
+ (let ((inverses '((reverse . reverse)
+ (reverse! . reverse!)
+ (list->vector . vector->list)
+ (vector->list . list->vector)
+ (symbol->string . string->symbol)
+ (string->symbol . symbol->string)
+ (list->string . string->list)
+ (string->list . list->string)
+ (number->string . string->number))))
+ (when (and (pair? (cdr form))
+ (pair? (cadr form))
+ (pair? (cdadr form)))
+ (let ((inv-op (assq head inverses))
+ (arg (cadr form))
+ (arg-of-arg (cadadr form))
+ (func-of-arg (caadr form)))
+ (if (pair? inv-op) (set! inv-op (cdr inv-op)))
+
+ (cond ((eq? func-of-arg inv-op) ; (vector->list (list->vector x)) -> x
+ (if (eq? head 'string->symbol)
+ (lint-format "perhaps ~A" caller (lists->string form arg-of-arg))
+ (lint-format "~A could be (copy ~S)" caller form arg-of-arg)))
- ;; if it's car|cdr followed by cdr's, use list-ref|tail
- ((not (char-position #\a cxr))
- (lint-format "perhaps ~A" caller (lists->string form `(list-tail ,arg ,(length cxr)))))
+ ((and (eq? head 'list->string) ; (list->string (vector->list x)) -> (copy x (make-string (length x)))
+ (eq? func-of-arg 'vector->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-string (length ,arg-of-arg))))))
- ((not (char-position #\a (substring cxr 1)))
- (lint-format "perhaps ~A" caller (lists->string form `(list-ref ,arg ,(- (length cxr) 1)))))
+ ((and (eq? head 'list->string) ; (list->string (make-list x y)) -> (make-string x y)
+ (eq? func-of-arg 'make-list))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-string ,@(cdr arg)))))
- (else (set! last-simplify-cxr-line-number -1)))))
- (combine-cxrs form)))
-
- (when (pair? (cadr form))
- (when (eq? head 'car)
- (if (eq? (caadr form) 'list-tail) ; (car (list-tail x y)) -> (list-ref x y)
- (lint-format "perhaps ~A" caller (lists->string form `(list-ref ,(cadadr form) ,(caddr (cadr form)))))
- (if (and (memq (caadr form) '(memq memv member assq assv assoc))
- (pair? (cdadr form))) ; (car (memq...))
- (lint-format "~A is ~A, or an error" caller (truncated-list->string form) (cadadr form)))))
-
- (if (and (memq head '(car cdr))
- (eq? (caadr form) 'cons))
- (lint-format "(~A~A) is the same as ~A"
- caller head
- (truncated-list->string (cadr form))
- (if (eq? head 'car)
- (truncated-list->string (cadadr form))
- (truncated-list->string (caddr (cadr form))))))
-
- (when (memq head '(car cadr caddr cadddr))
- (if (memq (caadr form) '(string->list vector->list)) ; (car (string->list x)) -> (string-ref x 0)
- (lint-format "perhaps ~A" caller (lists->string form `(,(if (eq? (caadr form) 'string->list) 'string-ref 'vector-ref)
- ,(cadadr form)
- ,(case head ((car) 0) ((cadr) 1) ((caddr) 2) (else 3)))))
- (if (and (memq (caadr form) '(reverse reverse!))
- (symbol? (cadadr form)))
- (lint-format "perhaps ~A" caller ; (car (reverse x)) -> (list-ref x (- (length x) 1))
- (lists->string form `(list-ref ,(cadadr form)
- (- (length ,(cadadr form))
- ,(case head ((car) 1) ((cadr) 2) ((caddr) 3) (else 4)))))))))))
-
- ;; ----------------
- ((set-car!)
- (when (= (length form) 3)
- (let ((target (cadr form)))
- (if (pair? target)
- (case (car target)
-
- ((list-tail) ; (set-car! (list-tail x y) z) -> (list-set! x y z)
- (lint-format "perhaps ~A" caller (lists->string form `(list-set! ,(cadr target) ,(caddr target) ,(caddr form)))))
-
- ((cdr cddr cdddr cddddr)
- (set! last-simplify-cxr-line-number line-number)
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (pair? (cadr target))
- (memq (caadr target) '(cdr cddr cdddr cddddr)))
- ;; (set-car! (cdr (cddr x)) y) -> (list-set! x 3 y)
- `(list-set! ,(cadadr target)
- ,(+ (cdr-count (car target)) (cdr-count (caadr target)))
- ,(caddr form))
- ;; (set-car! (cdr x) y) -> (list-set! x 1 y)
- `(list-set! ,(cadr target)
- ,(cdr-count (car target))
- ,(caddr form)))))))))))
- ;; ----------------
- ((not)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (eq? (caadr form) 'not))
- (lint-format "if you want a boolean, (not (not ~A)) -> (and ~A #t)" 'paranoia
- (truncated-list->string (cadadr form))
- (truncated-list->string (cadadr form))))
- (if (not (= line-number last-simplify-boolean-line-number))
- (let ((val (simplify-boolean form () () env)))
- (set! last-simplify-boolean-line-number line-number)
- (if (not (equal? form val))
- (lint-format "perhaps ~A" caller (lists->string form val))))))
-
- ((or and)
- (if (not (= line-number last-simplify-boolean-line-number))
- (let ((val (simplify-boolean form () () env)))
- (set! last-simplify-boolean-line-number line-number)
- (if (not (equal? form val))
- (lint-format "perhaps ~A" caller (lists->string form val)))))
- (if (pair? (cdr form))
- (do ((p (cdr form) (cdr p)))
- ((null? (cdr p)))
- (if (and (pair? (car p))
- (eq? (caar p) 'if)
- (= (length (car p)) 3))
- (lint-format "one-armed if might cause confusion here: ~A" caller form)))))
-
- ;; ----------------
- ((=)
- (let ((len (length form)))
- (if (and (> len 2)
- (any-real? (cdr form)))
- (lint-format "= can be troublesome with floats: ~A" caller (truncated-list->string form)))
-
- (let ((cleared-form (cons = (remove-if (lambda (x) (not (number? x))) (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
-
- (when (= len 3)
- (let ((arg1 (cadr form))
- (arg2 (caddr form)))
- (let ((var (or (and (memv arg1 '(0 1))
- (pair? arg2)
- (eq? (car arg2) 'length)
- (cadr arg2))
- (and (memv arg2 '(0 1))
- (pair? arg1)
- (eq? (car arg1) 'length)
- (cadr arg1)))))
- (if var
- (if (or (eqv? arg1 0)
- (eqv? arg2 0))
- (lint-format "perhaps (assuming ~A is a list), ~A" caller var
- (lists->string form `(null? ,var)))
- (if (symbol? var)
- (lint-format "perhaps (assuming ~A is a list), ~A" caller var
- (lists->string form `(and (pair? ,var) (null? (cdr ,var))))))))))
- (unrelop caller '= form))
- (check-char-cmp caller head form)))
-
- ;; ----------------
- ((< > <= >=) ; '= handled above
- (let ((cleared-form (cons head ; keep operator
- (remove-if (lambda (x)
- (not (number? x)))
- (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
-
- (if (= (length form) 3)
- (unrelop caller head form)
- (when (> (length form) 3)
- (if (and (memq head '(< >))
- (repeated-member? (cdr form) env))
- (lint-format "perhaps ~A" caller (truncated-lists->string form #f))
- (if (and (memq head '(<= >=))
- (repeated-member? (cdr form) env))
- (let ((last-arg (cadr form))
- (new-args (list (cadr form))))
- (do ((lst (cddr form) (cdr lst)))
- ((null? lst)
- (if (repeated-member? new-args env)
- (lint-format "perhaps ~A" caller (truncated-lists->string form `(= ,@(lint-remove-duplicates (reverse new-args) env))))
- (if (< (length new-args) (length (cdr form)))
- (lint-format "perhaps ~A" caller
- (truncated-lists->string form (or (null? (cdr new-args))
- `(= ,@(reverse new-args))))))))
- (unless (equal? (car lst) last-arg)
- (set! last-arg (car lst))
- (set! new-args (cons last-arg new-args)))))))))
-
- (when (= (length form) 3)
- (cond ((and (eqv? (cadr form) 0)
- (eq? head '>)
- (pair? (caddr form))
- (hash-table-ref non-negative-ops (caaddr form)))
- (lint-format "~A can't be negative: ~A" caller (caaddr form) (truncated-list->string form)))
-
- ((and (eqv? (caddr form) 0)
- (eq? head '<)
- (pair? (cadr form))
- (hash-table-ref non-negative-ops (caadr form)))
- (lint-format "~A can't be negative: ~A" caller (caadr form) (truncated-list->string form)))
-
- ((and (pair? (cadr form))
- (eq? (caadr form) 'length))
- (let ((arg (cadadr form)))
- (when (symbol? arg)
- (if (eqv? (caddr form) 0)
- (lint-format "perhaps~A ~A" caller
- (if (eq? head '<) "" (format #f " (assuming ~A is a proper list)," arg))
- (lists->string form
- (case head
- ((<) `(and (pair? ,arg) (not (proper-list? ,arg))))
- ((<=) `(null? ,arg))
- ((>) `(pair? ,arg))
- ((>=) `(list? ,arg)))))
- (if (and (eqv? (caddr form) 1)
- (not (eq? head '>)))
- (lint-format "perhaps (assuming ~A is a proper list), ~A" caller arg
- (lists->string form
- (case head
- ((<) `(null? ,arg))
- ((<=) `(or (null? ,arg) (null? (cdr ,arg))))
- ((>) `(and (pair? ,arg) (pair? (cdr ,arg))))
- ((>=) `(pair? ,arg))))))))))
- ((and (pair? (caddr form))
- (eq? (caaddr form) 'length))
- (let ((arg (cadr (caddr form))))
- (when (symbol? arg)
- (if (eqv? (cadr form) 0)
- (lint-format "perhaps~A ~A" caller
- (if (eq? head '>) "" (format #f " (assuming ~A is a proper list)," arg))
- (lists->string form
- (case head
- ((<) `(pair? ,arg))
- ((<=) `(list? ,arg))
- ((>) `(and (pair? ,arg) (not (proper-list? ,arg))))
- ((>=) `(null? ,arg)))))
- (if (and (eqv? (cadr form) 1)
- (not (eq? head '<)))
- (lint-format "perhaps (assuming ~A is a proper list), ~A" caller arg
- (lists->string form
- (case head
- ((<) `(and (pair? ,arg) (pair? (cdr ,arg))))
- ((<=) `(pair? ,arg))
- ((>) `(null? ,arg))
- ((>=) `(or (null? ,arg) (null? (cdr ,arg))))))))))))))
- (check-char-cmp caller head form))
- ;; could change (> x 0) to (positive? x) and so on, but the former is clear and ubiquitous
-
- ;; ----------------
- ((char<? char>? char<=? char>=? char=? char-ci<? char-ci>? char-ci<=? char-ci>=? char-ci=?)
- (let ((cleared-form (cons head ; keep operator
- (remove-if (lambda (x)
- (not (char? x)))
- (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
- (if (and (eq? head 'char-ci=?) ; (char-ci=? x #\return)
- (pair? (cdr form))
- (pair? (cddr form))
- (null? (cdddr form))
- (or (and (char? (cadr form))
- (char=? (cadr form) (other-case (cadr form))))
- (and (char? (caddr form))
- (char=? (caddr form) (other-case (caddr form))))))
- (lint-format "char-ci=? could be char=? here: ~A" caller form)))
-
- ;; ----------------
- ((string<? string>? string<=? string>=? string=? string-ci<? string-ci>? string-ci<=? string-ci>=? string-ci=?)
- (let ((cleared-form (cons head ; keep operator
- (remove-if (lambda (x)
- (not (string? x)))
- (cdr form)))))
- (if (and (> (length cleared-form) 2)
- (not (checked-eval cleared-form)))
- (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form))))
-
- (if (every? (lambda (a)
- (or (and (string? a)
- (= (length a) 1))
- (and (pair? a)
- (eq? (car a) 'string))))
- (cdr form))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(,(string->symbol (string-append "char" (substring (symbol->string head) 6)))
- ,@(map (lambda (a)
- (if (string? a)
- (string-ref a 0)
- (cadr a)))
- (cdr form)))))))
- ;; ----------------
- ((length)
- (when (pair? (cdr form))
- (if (pair? (cadr form))
- (let ((arg (cadr form)))
- (case (car arg)
- ((string->list vector->list)
- (if (null? (cddr arg)) ; string->list has start:end etc
- (lint-format "perhaps ~A" caller (lists->string form `(length ,(cadr arg))))
- (if (pair? (cdddr arg))
- (if (and (integer? (cadddr arg))
- (integer? (caddr arg)))
- (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (max 0 (- (cadddr arg) (caddr arg))))
- (lint-format "perhaps ~A" caller (lists->string form `(- ,(cadddr arg) ,(caddr arg)))))
- (lint-format "perhaps ~A" caller (lists->string form `(- (length ,(cadr arg)) ,(caddr arg)))))))
- ((reverse reverse! list->vector list->string let->list)
- (lint-format "perhaps ~A" caller (lists->string form `(length ,(cadr arg)))))
- ((cons)
- (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(caddr arg)) 1))))
- ((make-list)
- (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))
- ((list)
- (lint-format "perhaps ~A" caller (lists->string form (- (length arg) 1))))
- ((append)
- (if (= (length arg) 3)
- (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(cadr arg)) (length ,(caddr arg)))))))
- ((quote)
- (if (list? (cadr arg))
- (lint-format "perhaps ~A" caller (lists->string form (length (cadr arg))))))))
- ;; not pair cadr
- (if (code-constant? (cadr form))
- (lint-format "perhaps ~A -> ~A" caller
- (truncated-list->string form)
- (length (if (and (pair? (cadr form))
- (eq? (caadr form) 'quote))
- (cadadr form)
- (cadr form))))))))
- ;; ----------------
- ((zero? positive? negative?)
- (when (pair? (cdr form))
- (let ((arg (cadr form)))
- (when (pair? arg)
-
- (if (and (eq? head 'negative?)
- (hash-table-ref non-negative-ops (car arg)))
- (lint-format "~A can't be negative: ~A" caller head (truncated-list->string form)))
-
- (case (car arg)
- ((-)
- (lint-format "perhaps ~A" caller
- (lists->string form
- (let ((op '((zero? = zero?) (positive? > negative?) (negative? < positive?))))
- (if (null? (cddr arg))
- `(,(caddr (assq head op)) ,(cadr arg))
- (if (null? (cdddr arg))
- `(,(cadr (assq head op)) ,(cadr arg) ,(caddr arg))
- `(,(cadr (assq head op)) ,(cadr arg) (+ ,@(cddr arg)))))))))
- ((denominator)
- (if (eq? head 'zero)
- (lint-format "denominator can't be zero: ~A" caller form)))
-
- ((length)
- (if (eq? head 'zero?)
- (lint-format "perhaps (assuming ~A is list) use null? instead of length: ~A" caller (cadr arg)
- (lists->string form `(null? ,(cadr arg)))))))))))
- ;; (zero? (logand...)) is nearly always preceded by not and handled elsewhere
-
- ;; ----------------
- ((/)
- (when (pair? (cdr form))
- (if (and (null? (cddr form))
- (number? (cadr form))
- (zero? (cadr form)))
- (lint-format "attempt to invert zero: ~A" caller (truncated-list->string form))
- (if (and (pair? (cddr form))
- (memv 0 (cddr form)))
- (lint-format "attempt to divide by 0: ~A" caller (truncated-list->string form))))))
-
- ;; ----------------
- ((copy)
- (cond ((and (pair? (cdr form))
- (or (number? (cadr form))
- (boolean? (cadr form))
- (char? (cadr form))
- (and (pair? (cadr form))
- (memq (caadr form) '(copy string-copy))) ; or any maker?
- (and (pair? (cddr form))
- (equal? (cadr form) (caddr form)))))
- (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form)))
-
- ((and (pair? (cdr form))
- (equal? (cadr form) '(owlet)))
- (lint-format "~A could be (owlet): owlet is copied internally" caller form))
-
- ((= (length form) 5)
- (check-start-and-end caller head (cdddr form) form env))))
-
- ;; ----------------
- ((string-copy)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (memq (caadr form) '(copy string-copy string make-string string-upcase string-downcase
- string-append list->string symbol->string number->string)))
- (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))))
-
- ;; ----------------
- ((string)
- (if (every? (lambda (x)
- (and (char? x)
- (char<=? #\space x #\~))) ; #\0xx chars here look dumb
- (cdr form))
- (lint-format "~A could be ~S" caller (truncated-list->string form) (apply string (cdr form)))))
-
- ;; ----------------
- ((string?)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (memq (caadr form) '(format number->string)))
- (if (eq? (caadr form) 'format)
- (lint-format "format returns either #f or a string, so ~A" caller (lists->string form (cadr form)))
- (lint-format "number->string always returns a string, so ~A" caller (lists->string form #t)))
- (check-boolean-affinity caller form env)))
-
- ((number?)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (eq? (caadr form) 'string->number))
- (lint-format "string->number returns either #f or a number, so ~A" caller (lists->string form (cadr form)))
- (check-boolean-affinity caller form env)))
-
- ((symbol? rational? real? complex? float? keyword? gensym? byte-vector? proper-list?
- char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? c-object?
- output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer?)
- (check-boolean-affinity caller form env))
-
- ((pair? list?)
- (check-boolean-affinity caller form env)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (memq (caadr form) '(memq memv member assq assv assoc procedure-signature)))
- (lint-format "~A returns either #f or a pair, so ~A" caller (caadr form)
- (lists->string form (cadr form)))))
-
- ((integer?)
- (check-boolean-affinity caller form env)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (memq (caadr form) '(char-position string-position)))
- (lint-format "~A returns either #f or an integer, so ~A" caller (caadr form)
- (lists->string form (cadr form)))))
-
- ((null?)
- (check-boolean-affinity caller form env)
- (if (and (pair? (cdr form))
- (pair? (cadr form))
- (memq (caadr form) '(vector->list string->list let->list)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(zero? (length ,(cadadr form)))))))
-
- ;; ----------------
- ((string-ref)
- (when (and (= (length form) 3)
- (pair? (cadr form)))
- (let ((target (cadr form)))
- (case (car target)
- ((substring)
- (if (= (length target) 3)
- (lint-format "perhaps ~A" caller (lists->string form `(string-ref ,(cadr target) (+ ,(caddr form) ,(caddr target)))))))
- ((symbol->string)
- (if (and (integer? (caddr form))
- (pair? (cadr target))
- (eq? (caadr target) 'quote)
- (symbol? (cadadr target)))
- (lint-format "perhaps ~A" caller (lists->string form (string-ref (symbol->string (cadadr target)) (caddr form))))))
- ((make-string)
- (if (and (integer? (cadr target))
- (integer? (caddr form))
- (> (cadr target) (caddr form)))
- (lint-format "perhaps ~A" caller (lists->string form (if (= (length target) 3) (caddr target) #\space)))))))))
-
- ;; ----------------
- ((vector-ref list-ref hash-table-ref let-ref int-vector-ref float-vector-ref)
- (unless (= line-number last-checker-line-number)
- (when (= (length form) 3)
- (let ((seq (cadr form)))
- (when (pair? seq)
- (if (and (memq (car seq) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref))
- (= (length seq) 3)) ; (vector-ref (vector-ref x i) j) -> (x i j)
- (let ((seq1 (cadr seq))) ; x
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (pair? seq1) ; (vector-ref (vector-ref (vector-ref x i) j) k) -> (x i j k)
- (memq (car seq1) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref))
- (= (length seq1) 3))
- `(,(cadr seq1) ,(caddr seq1) ,(caddr seq) ,(caddr form))
- `(,seq1 ,(caddr seq) ,(caddr form))))))
- (if (memq (car seq) '(make-vector make-list vector list
- make-float-vector make-int-vector float-vector int-vector
- make-hash-table hash-table hash-table*
- inlet))
- (lint-format "this doesn't make much sense: ~A" caller form)))
- (if (and (eq? head 'list-ref)
- (eq? (car seq) 'quote)
- (proper-list? (cadr seq)))
- (lint-format "perhaps use a vector: ~A" caller
- (lists->string form `(vector-ref ,(apply vector (cadr seq)) ,(caddr form))))))))
- (set! last-checker-line-number line-number)))
-
- ;; ----------------
- ((vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! string-set! let-set!)
- (when (= (length form) 4)
- (let ((target (cadr form))
- (index (caddr form))
- (val (cadddr form)))
-
- (cond ((and (pair? val) ; (vector-set! x 0 (vector-ref x 0))
- (= (length val) 3)
- (eq? target (cadr val))
- (equal? index (caddr val))
- (memq (car val) '(vector-ref list-ref hash-table-ref string-ref let-ref float-vector-ref int-vector-ref)))
- (lint-format "redundant ~A: ~A" caller head (truncated-list->string form)))
-
- ((and (pair? target) ; (vector-set! (vector-ref x 0) 1 2) -- vector within vector
- (not (eq? head 'string-set!))
- (memq (car target) '(vector-ref list-ref hash-table-ref let-ref float-vector-ref int-vector-ref)))
- (lint-format "perhaps ~A" caller (lists->string form `(set! (,@(cdr target) ,index) ,val))))
-
- ((and (pair? target) ; (vector-set! (make-vector 3) 1 1) -- does this ever happen?
- (memq (car target) '(make-vector vector make-string string make-list list append cons vector-append copy inlet sublet)))
- (lint-format "~A is simply discarded; perhaps ~A" caller
- (truncated-list->string target)
- (lists->string form val)))
-
- ((code-constant? target) ; (vector-set! #(0 1 2) 1 3)??
- (lint-format "~A is a constant that is discarded; perhaps ~A" caller target (lists->string form val)))))))
-
- ;; ----------------
- ((object->string)
- (when (pair? (cdr form))
- (if (and (pair? (cadr form))
- (eq? (caadr form) 'object->string))
- (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))
- (if (pair? (cddr form))
- (let ((arg2 (caddr form)))
- (if (or (and (keyword? arg2)
- (not (eq? arg2 :readable)))
- (and (code-constant? arg2)
- (not (boolean? arg2))))
- (lint-format "bad second argument: ~A" caller arg2)))))))
-
- ;; ----------------
- ((display)
- (if (and (pair? (cdr form))
- (pair? (cadr form)))
- (let ((arg (cadr form))
- (port (if (pair? (cddr form))
- (caddr form)
- ())))
- (cond ((and (string? arg)
- (or (string-position "ERROR" arg)
- (string-position "WARNING" arg)))
- (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))
-
- ((and (eq? (car arg) 'format)
- (pair? (cdr arg))
- (not (cadr arg)))
- (lint-format "perhaps ~A" caller (lists->string form `(format ,port ,@(cddr arg)))))
-
- ((and (eq? (car arg) 'apply)
- (pair? (cdr arg))
- (eq? (cadr arg) 'format)
- (pair? (cddr arg))
- (not (caddr arg)))
- (lint-format "perhaps ~A" caller (lists->string form `(apply format ,port ,@(cdddr arg)))))))))
-
- ;; ----------------
- ((make-vector make-int-vector make-float-vector)
- ;; type of initial value is checked elsewhere
- (if (and (= (length form) 4)
- (eq? head 'make-vector)
- (code-constant? (caddr form))
- (not (real? (caddr form)))
- (eq? (cadddr form) #t))
- (lint-format "~A won't create an homogeneous vector" caller form))
- (when (and (pair? (cdr form))
- (integer? (cadr form))
- (zero? (cadr form)))
- (if (pair? (cddr form))
- (lint-format "initial value is pointless here: ~A" caller form))
- (lint-format "perhaps ~A" caller (lists->string form #()))))
-
- ;; ----------------
- ((make-string make-byte-vector)
- (when (and (pair? (cdr form))
- (integer? (cadr form))
- (zero? (cadr form)))
- (if (pair? (cddr form))
- (lint-format "initial value is pointless here: ~A" caller form))
- (lint-format "perhaps ~A" caller (lists->string form "")))) ; #u8() but (equal? #u8() "") -> #t so lint combines these clauses!
-
- ;; ----------------
- ((make-list)
- (when (and (pair? (cdr form))
- (integer? (cadr form))
- (zero? (cadr form)))
- (if (pair? (cddr form))
- (lint-format "initial value is pointless here: ~A" caller form))
- (lint-format "perhaps ~A" caller (lists->string form ()))))
-
- ;; ----------------
- ((reverse reverse! list->vector vector->list list->string string->list symbol->string string->symbol number->string)
- ;; not string->number -- no point in copying a number and it's caught below
-
- (let ((inverses '((reverse . reverse)
- (reverse! . reverse!)
- (list->vector . vector->list)
- (vector->list . list->vector)
- (symbol->string . string->symbol)
- (string->symbol . symbol->string)
- (list->string . string->list)
- (string->list . list->string)
- (number->string . string->number))))
- (when (and (pair? (cdr form))
- (pair? (cadr form))
- (pair? (cdadr form)))
- (let ((inv-op (assq head inverses))
- (arg (cadr form))
- (arg-of-arg (cadadr form))
- (func-of-arg (caadr form)))
- (if (pair? inv-op) (set! inv-op (cdr inv-op)))
-
- (cond ((eq? func-of-arg inv-op) ; (vector->list (list->vector x)) -> x
- (if (eq? head 'string->symbol)
- (lint-format "perhaps ~A" caller (lists->string form arg-of-arg))
- (lint-format "~A could be (copy ~S)" caller form arg-of-arg)))
-
- ((and (eq? head 'list->string) ; (list->string (vector->list x)) -> (copy x (make-string (length x)))
- (eq? func-of-arg 'vector->list))
- (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-string (length ,arg-of-arg))))))
-
- ((and (eq? head 'list->string) ; (list->string (make-list x y)) -> (make-string x y)
- (eq? func-of-arg 'make-list))
- (lint-format "perhaps ~A" caller (lists->string form `(make-string ,@(cdr arg)))))
-
- ((and (eq? head 'list->vector) ; (list->vector (make-list ...)) -> (make-vector ...)
- (eq? func-of-arg 'make-list))
- (lint-format "perhaps ~A" caller (lists->string form `(make-vector ,@(cdr arg)))))
+ ((and (eq? head 'list->vector) ; (list->vector (make-list ...)) -> (make-vector ...)
+ (eq? func-of-arg 'make-list))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-vector ,@(cdr arg)))))
+
+ ((and (eq? head 'list->vector) ; (list->vector (string->list x)) -> (copy x (make-vector (length x)))
+ (eq? func-of-arg 'string->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-vector (length ,arg-of-arg))))))
+
+ ((and (eq? head 'vector->list) ; (vector->list (make-vector ...)) -> (make-list ...)
+ (eq? func-of-arg 'make-vector))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-list ,@(cdr arg)))))
+
+ ((and (memq func-of-arg '(reverse reverse! copy))
+ (pair? (cadr arg)) ; (list->string (reverse (string->list x))) -> (reverse x)
+ (eq? (caadr arg) inv-op))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(if (eq? func-of-arg 'reverse!) 'reverse func-of-arg) ,(cadadr arg)))))
+
+ ((and (memq head '(reverse reverse!)) ; (reverse (string->list x)) -> (string->list (reverse x)) -- often redundant
+ (memq func-of-arg '(string->list vector->list))
+ (null? (cddr arg)))
+ (lint-format "perhaps less consing: ~A" caller
+ (lists->string form `(,func-of-arg (reverse ,arg-of-arg)))))
+
+ ((and (pair? (cadr arg))
+ (memq func-of-arg '(cdr cddr cdddr cddddr list-tail))
+ (case head
+ ((list->string) (eq? (caadr arg) 'string->list))
+ ((list->vector) (eq? (caadr arg) 'vector->list))
+ (else #f)))
+ (let ((len-diff (if (eq? func-of-arg 'list-tail)
+ (caddr arg)
+ (cdr-count func-of-arg))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if (eq? head 'list->string)
+ `(substring ,(cadadr arg) ,len-diff)
+ `(copy ,(cadadr arg) (make-vector (- (length ,(cadadr arg)) ,len-diff))))))))
+
+ ((and (memq head '(list->vector list->string))
+ (eq? func-of-arg 'sort!)
+ (pair? (cadr arg))
+ (eq? (caadr arg) (if (eq? head 'list->vector) 'vector->list 'string->list)))
+ (lint-format "perhaps ~A" caller (lists->string form `(sort! ,(cadadr arg) ,(caddr arg)))))
+
+ ((and (memq head '(list->vector list->string))
+ (or (memq func-of-arg '(list cons))
+ (quoted-undotted-pair? arg)))
+ (let ((maker (if (eq? head 'list->vector) 'vector 'string)))
+ (cond ((eq? func-of-arg 'list)
+ (if (var-member maker env)
+ (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker)
+ (lint-format "perhaps ~A" caller (lists->string form `(,maker ,@(cdr arg))))))
+ ((eq? func-of-arg 'cons)
+ (if (any-null? (caddr arg))
+ (if (var-member maker env)
+ (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker)
+ (lint-format "perhaps ~A" caller (lists->string form `(,maker ,(cadr arg)))))))
+ ((or (null? (cddr form))
+ (and (integer? (caddr form))
+ (or (null? (cdddr form))
+ (integer? (cadddr form)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (apply (if (eq? head 'list->vector) vector string) (cadr arg))))))))
+
+ ((and (eq? head 'list->string) ; (list->string (reverse x)) -> (reverse (apply string x))
+ (memq func-of-arg '(reverse reverse!)))
+ (lint-format "perhaps ~A" caller (lists->string form `(reverse (apply string ,arg-of-arg)))))
+
+ ((and (memq head '(string->list vector->list))
+ (= (length form) 4))
+ (check-start-and-end caller head (cddr form) form env))
+
+ ((and (eq? head 'string->symbol) ; (string->symbol (string-append...)) -> (symbol ...)
+ (or (memq func-of-arg '(string-append append))
+ (and (eq? func-of-arg 'apply)
+ (memq arg-of-arg '(string-append append)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? func-of-arg 'apply)
+ `(apply symbol ,@(cddr arg))
+ `(symbol ,@(cdr arg))))))
+
+ ((and (eq? head 'string->symbol)
+ (eq? func-of-arg 'if)
+ (or (string? (caddr arg))
+ (string? (cadddr arg)))
+ (not (or (equal? (caddr arg) "") ; this is actually an error -- should we complain?
+ (equal? (cadddr arg) ""))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (string? (caddr arg))
+ (if (string? (cadddr arg))
+ `(if ,(cadr arg) ',(string->symbol (caddr arg)) ',(string->symbol (cadddr arg)))
+ `(if ,(cadr arg) ',(string->symbol (caddr arg)) (string->symbol ,(cadddr arg))))
+ `(if ,(cadr arg) (string->symbol ,(caddr arg)) ',(string->symbol (cadddr arg)))))))
+
+ ((and (eq? head 'symbol->string) ; (string->symbol "constant-string") never happens, but the reverse does?
+ (quoted-symbol? arg))
+ (lint-format "perhaps ~A" caller (lists->string form (symbol->string (cadadr form)))))
+
+ ((case head
+ ((reverse) (eq? func-of-arg 'reverse!))
+ ((reverse!) (eq? func-of-arg 'reverse))
+ (else #f))
+ (lint-format "~A could be (copy ~S)" caller form arg-of-arg))
+
+ ((and (pair? arg-of-arg) ; (op (reverse (inv-op x))) -> (reverse x)
+ (eq? func-of-arg 'reverse)
+ (eq? inv-op (car arg-of-arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(reverse ,(cadr arg-of-arg)))))))))
+
+ (when (and (pair? (cdr form))
+ (not (pair? (cadr form))))
+ (let ((arg (cadr form)))
+ (if (and (eq? head 'string->list)
+ (string? arg)
+ (or (null? (cddr form))
+ (and (integer? (caddr form))
+ (or (null? (cdddr form))
+ (integer? (cadddr form))))))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (apply string->list (cdr form))))))
+
+ (when (and (memq head '(vector->list string->list))
+ (pair? (cddr form))
+ (pair? (cdddr form))
+ (equal? (caddr form) (cadddr form)))
+ (lint-format "leaving aside errors, ~A is ()" caller (truncated-list->string form)))
+
+ (when (and (memq head '(reverse reverse!))
+ (pair? (cdr form))
+ (pair? (cadr form)))
+ (let ((arg (cadr form)))
+ (if (and (memq (car arg) '(cdr list-tail)) ; (reverse (cdr (reverse lst))) = all but last of lst -> copy to len-1
+ (pair? (cadr arg))
+ (memq (caadr arg) '(reverse reverse!))
+ (symbol? (cadadr arg)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(copy ,(cadadr arg) (make-list (- (length ,(cadadr arg)) ,(if (eq? (car arg) 'cdr) 1 (caddr arg))))))))
+
+ (if (and (eq? (car arg) 'append) ; (reverse (append (reverse b) res)) = (append (reverse res) b)
+ (pair? (cadr arg))
+ (eq? (caadr arg) 'reverse)
+ (pair? (cddr arg))
+ (null? (cdddr arg)))
+ (lint-format "perhaps ~A" caller (lists->string form `(append (reverse ,(caddr arg)) ,(cadadr arg)))))
+
+ (if (and (eq? (car arg) 'cons) ; (reverse (cons x (reverse lst))) -- adds x to end -- (append lst (list x))
+ (pair? (caddr arg))
+ (memq (car (caddr arg)) '(reverse reverse!)))
+ (lint-format "perhaps ~A" caller (lists->string form `(append ,(cadr (caddr arg)) (list ,(cadr arg)))))))))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-reverse))
+ '(reverse reverse! list->vector vector->list list->string string->list symbol->string string->symbol number->string)))
+
+ ;; ---------------- char->integer string->number etc ----------------
+ (let ()
+ (define (sp-char->integer caller head form env)
+ (let ((inverses '((char->integer . integer->char)
+ (integer->char . char->integer)
+ (symbol->keyword . keyword->symbol)
+ (keyword->symbol . symbol->keyword)
+ (string->number . number->string))))
+ (when (pair? (cdr form))
+ (let ((arg (cadr form)))
+ (cond ((and (pair? arg)
+ (pair? (cdr arg))
+ (eq? (car arg) (cond ((assq head inverses) => cdr))))
+ (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr arg)))
+
+ ((eq? head 'integer->char)
+ (if (let walk ((tree (cdr form)))
+ (if (pair? tree)
+ (and (walk (car tree))
+ (walk (cdr tree)))
+ (or (code-constant? tree)
+ (not (side-effect? tree env)))))
+ (let ((chr (checked-eval form)))
+ (if (char? chr)
+ (lint-format "perhaps ~A" caller (lists->string form chr))))))
+
+ ((and (eq? head 'symbol->keyword)
+ (pair? (cadr form))
+ (eq? (caadr form) 'string->symbol))
+ (lint-format "perhaps ~A" caller (lists->string form `(make-keyword ,(cadadr form))))))))))
+
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-char->integer))
+ '(char->integer integer->char symbol->keyword keyword->symbol string->number)))
+
+ ;; ---------------- string-append ----------------
+ (let ()
+ (define (sp-string-append caller head form env)
+ (unless (= line-number last-checker-line-number)
+ (let ((args (remove-all "" (splice-if (lambda (x) (eq? x 'string-append)) (cdr form)))))
+ ;(format *stderr* "args: ~A~%" args)
+ (if (member 'string args (lambda (a b) (and (pair? b) (eq? (car b) a))))
+ (let ((nargs ())) ; look for (string...) (string...) in the arg list and combine
+ (do ((p args (cdr p)))
+ ((null? p)
+ (set! args (reverse nargs)))
+ (if (and (pair? (car p))
+ (eq? (caar p) 'string)
+ (pair? (cdr p))
+ (pair? (cadr p))
+ (eq? (caadr p) 'string))
+ (begin
+ (set! nargs (cons `(string ,@(cdar p) ,@(cdadr p)) nargs))
+ (set! p (cdr p)))
+ (set! nargs (cons (car p) nargs))))))
+ (cond ((null? args) ; (string-append) -> ""
+ (lint-format "perhaps ~A" caller (lists->string form "")))
- ((and (eq? head 'list->vector) ; (list->vector (string->list x)) -> (copy x (make-vector (length x)))
- (eq? func-of-arg 'string->list))
- (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-vector (length ,arg-of-arg))))))
+ ((null? (cdr args)) ; (string-append a) -> a
+ (if (not (tree-memq 'values (cdr form)))
+ (lint-format "perhaps ~A, or use copy" caller (lists->string form (car args)))))
- ((and (eq? head 'vector->list) ; (vector->list (make-vector ...)) -> (make-list ...)
- (eq? func-of-arg 'make-vector))
- (lint-format "perhaps ~A" caller (lists->string form `(make-list ,@(cdr arg)))))
+ ((every? string? args) ; (string-append "a" "b") -> "ab"
+ (lint-format "perhaps ~A" caller (lists->string form (apply string-append args))))
- ((and (memq func-of-arg '(reverse reverse! copy))
- (pair? (cadr arg)) ; (list->string (reverse (string->list x))) -> (reverse x)
- (eq? (caadr arg) inv-op))
- (lint-format "perhaps ~A" caller (lists->string form `(,(if (eq? func-of-arg 'reverse!) 'reverse func-of-arg) ,(cadadr arg)))))
+ ((every? (lambda (a) ; (string-append "a" (string #\b)) -> "ab"
+ (or (string? a)
+ (and (pair? a)
+ (eq? (car a) 'string)
+ (char? (cadr a)))))
+ args)
+ (catch #t
+ (lambda ()
+ (let ((val (if (not (any? pair? args))
+ (apply string-append args)
+ (eval (cons 'string-append args)))))
+ (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val)))
+ (lambda args #f)))
+
+ ((every? (lambda (c) ; (string-append (make-string 3 #\a) (make-string 2 #\b)) -> (format #f "~NC~NC" 3 #\a 2 #\b)
+ (and (pair? c)
+ (eq? (car c) 'make-string)
+ (pair? (cdr c))
+ (pair? (cddr c))))
+ (cdr form))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(format #f ,(apply string-append (make-list (abs (length (cdr form))) "~NC"))
+ ,@(map (lambda (c) (values (cadr c) (caddr c))) (cdr form))))))
+
+ ((not (equal? args (cdr form)))
+ (lint-format "perhaps ~A" caller (lists->string form `(string-append , at args)))))
+ (set! last-checker-line-number line-number))))
+ (hash-table-set! h 'string-append sp-string-append))
+
+ ;; ---------------- vector-append ----------------
+ (let ()
+ (define (sp-vector-append caller head form env)
+ (unless (= line-number last-checker-line-number)
+ (let ((args (remove-all #() (splice-if (lambda (x) (eq? x 'vector-append)) (cdr form)))))
+ (cond ((null? args)
+ (lint-format "perhaps ~A" caller (lists->string form #())))
- ((and (pair? (cadr arg))
- (memq func-of-arg '(cdr cddr cdddr cddddr list-tail))
- (case head
- ((list->string) (eq? (caadr arg) 'string->list))
- ((list->vector) (eq? (caadr arg) 'vector->list))
- (else #f)))
- (let ((len-diff (if (eq? func-of-arg 'list-tail)
- (caddr arg)
- (cdr-count func-of-arg))))
- (lint-format "perhaps ~A" caller
- (lists->string form (if (eq? head 'list->string)
- `(substring ,(cadadr arg) ,len-diff)
- `(copy ,(cadadr arg) (make-vector (- (length ,(cadadr arg)) ,len-diff))))))))
+ ((null? (cdr args))
+ (lint-format "perhaps ~A" caller (lists->string form `(copy ,(car args)))))
- ((and (memq head '(list->vector list->string))
- (eq? func-of-arg 'sort!)
- (pair? (cadr arg))
- (eq? (caadr arg) (if (eq? head 'list->vector) 'vector->list 'string->list)))
- (lint-format "perhaps ~A" caller (lists->string form `(sort! ,(cadadr arg) ,(caddr arg)))))
+ ((every? vector? args)
+ (lint-format "perhaps ~A" caller (lists->string form (apply vector-append args))))
- ((and (memq head '(list->vector list->string))
- (or (memq func-of-arg '(list cons))
- (quoted-undotted-pair? arg)))
- (let ((maker (if (eq? head 'list->vector) 'vector 'string)))
- (cond ((eq? func-of-arg 'list)
- (if (var-member maker env)
- (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker)
- (lint-format "perhaps ~A" caller (lists->string form `(,maker ,@(cdr arg))))))
- ((eq? func-of-arg 'cons)
- (if (or (null? (caddr arg))
- (quoted-null? (caddr arg)))
- (if (var-member maker env)
- (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker)
- (lint-format "perhaps ~A" caller (lists->string form `(,maker ,(cadr arg)))))))
- ((or (null? (cddr form))
- (and (integer? (caddr form))
- (or (null? (cdddr form))
- (integer? (cadddr form)))))
+ ((not (equal? args (cdr form)))
+ (lint-format "perhaps ~A" caller (lists->string form `(vector-append , at args)))))
+ (set! last-checker-line-number line-number))))
+ (hash-table-set! h 'vector-append sp-vector-append))
+
+ ;; ---------------- cons ----------------
+ (let ()
+ (define (sp-cons caller head form env)
+ (when (and (= (length form) 3)
+ (not (= last-cons-line-number line-number)))
+ (cond ((and (pair? (caddr form))
+ (eq? (caaddr form) 'list)) ; (cons x (list ...)) -> (list x ...)
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,(cadr form) ,@(cdaddr form)))))
+
+ ((any-null? (caddr form)) ; (cons x '()) -> (list x)
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,(cadr form)))))
+
+ ((and (pair? (cadr form)) ; (cons (car x) (cdr x)) -> (copy x)
+ (pair? (caddr form))
+ (let ((x (assq (caadr form)
+ '((car cdr #t)
+ (caar cdar car) (cadr cddr cdr)
+ (caaar cdaar caar) (caadr cdadr cadr) (caddr cdddr cddr) (cadar cddar cdar)
+ (cadddr cddddr cdddr) (caaaar cdaaar caaar) (caaadr cdaadr caadr) (caadar cdadar cadar)
+ (caaddr cdaddr caddr) (cadaar cddaar cdaar) (cadadr cddadr cdadr) (caddar cdddar cddar)))))
+ (and x
+ (eq? (cadr x) (caaddr form))
+ (caddr x))))
+ => (lambda (cfunc)
+ (if (and cfunc
+ (equal? (cadadr form) (cadr (caddr form)))
+ (not (side-effect? (cadadr form) env)))
+ (lint-format "perhaps ~A" caller (lists->string form
+ (if (symbol? cfunc)
+ `(copy (,cfunc ,(cadadr form)))
+ `(copy ,(cadadr form))))))))
+
+ ((and (pair? (caddr form)) ; (cons a (cons b (cons ...))) -> (list a b ...), input ending in nil of course
+ (eq? (caaddr form) 'cons)) ; list handled above
+ (let loop ((args (list (cadr form))) (chain (caddr form)))
+ (if (pair? chain)
+ (if (eq? (car chain) 'list)
+ (begin
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,@(reverse args) ,@(cdr chain))))
+ (set! last-cons-line-number line-number))
+ (if (and (eq? (car chain) 'cons)
+ (pair? (cdr chain))
+ (pair? (cddr chain)))
+ (if (any-null? (caddr chain))
+ (begin
+ (lint-format "perhaps ~A" caller (lists->string form `(list ,@(reverse args) ,(cadr chain))))
+ (set! last-cons-line-number line-number))
+ (if (and (pair? (caddr chain))
+ (memq (caaddr chain) '(cons list)))
+ (loop (cons (cadr chain) args) (caddr chain))))))))))))
+ (hash-table-set! h 'cons sp-cons))
+
+ ;; ---------------- append ----------------
+ (let ()
+ (define (sp-append caller head form env)
+ (unless (= line-number last-checker-line-number)
+ (set! last-checker-line-number line-number)
+ (letrec ((splice-append (lambda (lst)
+ (cond ((null? lst)
+ ())
+ ((not (pair? lst))
+ lst)
+ ((and (pair? (car lst))
+ (eq? (caar lst) 'append))
+ (if (null? (cdar lst))
+ (if (null? (cdr lst)) ; (append) at end -> () to keep copy intact?
+ (list ())
+ (splice-append (cdr lst)))
+ (append (splice-append (cdar lst)) (splice-append (cdr lst)))))
+ ((or (null? (cdr lst))
+ (not (or (any-null? (car lst))
+ (and (pair? (car lst))
+ (eq? (caar lst) 'list)
+ (null? (cdar lst))))))
+ (cons (car lst) (splice-append (cdr lst))))
+ (else (splice-append (cdr lst)))))))
+
+ (let ((new-args (splice-append (cdr form)))) ; (append '(1) (append '(2) '(3))) -> (append '(1) '(2) '(3))
+ (let ((len1 (length new-args))
+ (suggestion made-suggestion))
+ (if (and (> len1 2)
+ (null? (list-ref new-args (- len1 1)))
+ (pair? (list-ref new-args (- len1 2)))
+ (memq (car (list-ref new-args (- len1 2))) '(list cons append map string->list vector->list make-list)))
+ (begin
+ (set-cdr! (list-tail new-args (- len1 2)) ())
+ (set! len1 (- len1 1))))
+
+ (define (append->list . items)
+ (let ((lst (list 'list)))
+ (for-each
+ (lambda (item)
+ (set! lst (append lst (if (eq? (car item) 'list)
+ (cdr item)
+ (distribute-quote (cadr item))))))
+ items)
+ lst))
+
+ (if (positive? len1)
+ (let ((last (list-ref new-args (- len1 1))))
+ ;; (define (f) (append '(1) '(2))) (define a (f)) (set! (a 1) 32) (f) -> '(1 32)
+ (if (and (pair? last)
+ (eq? (car last) 'quote)
+ (pair? (cdr last))
+ (pair? (cadr last)))
+ (lint-format "append does not copy its last argument, so ~A is dangerous" caller form))))
+
+ (case len1
+ ((0) ; (append) -> ()
+ (lint-format "perhaps ~A" caller (lists->string form ())))
+ ((1) ; (append x) -> x
+ (lint-format "perhaps ~A" caller (lists->string form (car new-args))))
+ ((2) ; (append (list x) ()) -> (list x)
+ (let ((arg2 (cadr new-args))
+ (arg1 (car new-args)))
+ (cond ((or (any-null? arg2)
+ (equal? arg2 '(list))) ; (append x ()) -> (copy x)
+ (lint-format "perhaps clearer: ~A" caller (lists->string form `(copy ,arg1))))
+
+ ((null? arg1) ; (append () x) -> x
+ (lint-format "perhaps ~A" caller (lists->string form arg2)))
+
+ ((not (pair? arg1)))
+
+ ((and (pair? arg2) ; (append (list x y) '(z)) -> (list x y z) or extensions thereof
+ (or (eq? (car arg1) 'list)
+ (quoted-undotted-pair? arg1))
+ (or (eq? (car arg2) 'list)
+ (quoted-undotted-pair? arg2)))
+ (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args))))
+
+ ((and (eq? (car arg1) 'list) ; (append (list x) y) -> (cons x y)
+ (pair? (cdr arg1))
+ (null? (cddr arg1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadr arg1) ,arg2))))
+
+ ((and (eq? (car arg1) 'list) ; (append (list x y) z) -> (cons x (cons y z))
+ (pair? (cdr arg1))
+ (pair? (cddr arg1))
+ (null? (cdddr arg1)))
+ (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadr arg1) (cons ,(caddr arg1) ,arg2)))))
+
+ ((and (eq? (car arg1) 'vector->list)
+ (pair? arg2)
+ (eq? (car arg2) 'vector->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(vector->list (append ,(cadr arg1) ,(cadr arg2))))))
+
+ ((and (eq? (car arg1) 'quote) ; (append '(x) y) -> (cons 'x y)
+ (pair? (cadr arg1))
+ (null? (cdadr arg1)))
(lint-format "perhaps ~A" caller
- (lists->string form (apply (if (eq? head 'list->vector) vector string) (cadr arg))))))))
-
- ((and (eq? head 'list->string) ; (list->string (reverse x)) -> (reverse (apply string x))
- (memq func-of-arg '(reverse reverse!)))
- (lint-format "perhaps ~A" caller (lists->string form `(reverse (apply string ,arg-of-arg)))))
-
- ((and (memq head '(string->list vector->list))
- (= (length form) 4))
- (check-start-and-end caller head (cddr form) form env))
-
- ((and (eq? head 'symbol->string) ; (string->symbol "constant-string") never happens, but the reverse does?
- (quoted-symbol? arg))
- (lint-format "perhaps ~A" caller (lists->string form (apply symbol->string (cdadr form)))))
-
- ((and (pair? arg-of-arg) ; (op (reverse (inv-op x))) -> (reverse x)
- (eq? func-of-arg 'reverse)
- (eq? inv-op (car arg-of-arg)))
- (lint-format "perhaps ~A" caller (lists->string form `(reverse ,(cadr arg-of-arg)))))))))
-
- (when (and (pair? (cdr form))
- (not (pair? (cadr form))))
- (let ((arg (cadr form)))
- (if (and (eq? head 'string->list)
- (string? arg)
- (or (null? (cddr form))
- (and (integer? (caddr form))
- (or (null? (cdddr form))
- (integer? (cadddr form))))))
- (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (apply string->list (cdr form))))))
-
- (when (and (memq head '(vector->list string->list))
- (pair? (cddr form))
- (pair? (cdddr form))
- (equal? (caddr form) (cadddr form)))
- (lint-format "leaving aside errors, ~A is ()" caller (truncated-list->string form)))
-
- (when (and (memq head '(reverse reverse!))
- (pair? (cdr form))
- (pair? (cadr form)))
- (let ((arg (cadr form)))
- (if (and (memq (car arg) '(cdr list-tail)) ; (reverse (cdr (reverse lst))) = all but last of lst -> copy to len-1
- (pair? (cadr arg))
- (memq (caadr arg) '(reverse reverse!))
- (symbol? (cadadr arg)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(copy ,(cadadr arg) (make-list (- (length ,(cadadr arg)) ,(if (eq? (car arg) 'cdr) 1 (caddr arg))))))))
-
- (if (and (eq? (car arg) 'append) ; (reverse (append (reverse b) res)) = (append (reverse res) b)
- (pair? (cadr arg))
- (eq? (caadr arg) 'reverse)
- (pair? (cddr arg))
- (null? (cdddr arg)))
- (lint-format "perhaps ~A" caller (lists->string form `(append (reverse ,(caddr arg)) ,(cadadr arg)))))
-
- (if (and (eq? (car arg) 'cons) ; (reverse (cons x (reverse lst))) -- adds x to end -- (append lst (list x))
- (pair? (caddr arg))
- (memq (car (caddr arg)) '(reverse reverse!)))
- (lint-format "perhaps ~A" caller (lists->string form `(append ,(cadr (caddr arg)) (list ,(cadr arg)))))))))
-
- ;; ----------------
- ((char->integer integer->char symbol->keyword keyword->symbol string->number)
- (let ((inverses '((char->integer . integer->char)
- (integer->char . char->integer)
- (symbol->keyword . keyword->symbol)
- (keyword->symbol . symbol->keyword)
- (string->number . number->string))))
- (cond ((and (pair? (cdr form))
- (pair? (cadr form))
- (pair? (cdadr form))
- (eq? (caadr form) (cond ((assq head inverses) => cdr))))
- (lint-format "~A could be ~A" caller (truncated-list->string form) (cadadr form)))
-
- ((and (eq? head 'integer->char)
- (pair? (cdr form))
- (integer? (cadr form))
- (or (<= 32 (cadr form) 127)
- (memv (cadr form) '(0 7 8 9 10 13 27))))
- (lint-format "perhaps ~A -> ~W" caller (truncated-list->string form) (integer->char (cadr form))))
-
- ((and (eq? head 'symbol->keyword)
- (pair? (cdr form))
- (pair? (cadr form))
- (eq? (caadr form) 'string->symbol))
- (lint-format "perhaps ~A" caller (lists->string form `(make-keyword ,(cadadr form))))))))
-
- ;; ----------------
- ((string-append)
- (unless (= line-number last-checker-line-number)
- (let ((args (remove-all "" (splice-if (lambda (x) (eq? x 'string-append)) (cdr form)))))
- (if (member 'string args (lambda (a b) (and (pair? b) (eq? (car b) a))))
- (let ((nargs ())) ; look for (string...) (string...) in the arg list and combine
- (do ((p args (cdr p)))
- ((null? p)
- (set! args (reverse nargs)))
- (if (and (pair? (car p))
- (pair? (cadr p))
- (eq? (caar p) 'string)
- (eq? (caadr p) 'string))
- (begin
- (set! nargs (cons `(string ,@(cdar p) ,@(cdadr p)) nargs))
- (set! p (cdr p)))
- (set! nargs (cons (car p) nargs))))))
- (cond ((null? args) ; (string-append) -> ""
- (lint-format "perhaps ~A" caller (lists->string form "")))
- ((null? (cdr args)) ; (string-append a) -> a
- (if (not (tree-memq 'values (cdr form)))
- (lint-format "perhaps ~A, or use copy" caller (lists->string form (car args)))))
- ((every? string? args) ; (string-append "a" "b") -> "ab"
- (lint-format "perhaps ~A" caller (lists->string form (apply string-append args))))
- ((every? (lambda (a) ; (string-append "a" (string #\b)) -> "ab"
- (or (string? a)
- (and (pair? a)
- (eq? (car a) 'string)
- (char? (cadr a)))))
- args)
- (catch #t
- (lambda ()
- (let ((val (eval `(string-append , at args))))
- (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val)))
- (lambda args #f)))
- ((not (equal? args (cdr form)))
- (lint-format "perhaps ~A" caller (lists->string form `(string-append , at args)))))
- (set! last-checker-line-number line-number))))
-
- ;; ----------------
- ((vector-append)
- (unless (= line-number last-checker-line-number)
- (let ((args (remove-all #() (splice-if (lambda (x) (eq? x 'vector-append)) (cdr form)))))
- (cond ((null? args)
- (lint-format "perhaps ~A" caller (lists->string form #())))
- ((null? (cdr args))
- (lint-format "perhaps ~A" caller (lists->string form `(copy ,(car args)))))
- ((every? vector? args)
- (lint-format "perhaps ~A" caller (lists->string form (apply vector-append args))))
- ((not (equal? args (cdr form)))
- (lint-format "perhaps ~A" caller (lists->string form `(vector-append , at args)))))
- (set! last-checker-line-number line-number))))
-
- ;; ----------------
- ((cons)
- (when (and (= (length form) 3)
- (not (= last-cons-line-number line-number)))
- (cond ((and (pair? (caddr form))
- (eq? (caaddr form) 'list)) ; (cons x (list ...)) -> (list x ...)
- (lint-format "perhaps ~A" caller (lists->string form `(list ,(cadr form) ,@(cdaddr form)))))
-
- ((or (null? (caddr form)) ; (cons x '()) -> (list x)
- (quoted-null? (caddr form)))
- (lint-format "perhaps ~A" caller (lists->string form `(list ,(cadr form)))))
-
- ((and (pair? (cadr form)) ; (cons (car x) (cdr x)) -> (copy x)
- (pair? (caddr form))
- (let ((x (assq (caadr form)
- '((car cdr #t)
- (caar cdar car) (cadr cddr cdr)
- (caaar cdaar caar) (caadr cdadr cadr) (caddr cdddr cddr) (cadar cddar cdar)
- (cadddr cddddr cdddr) (caaaar cdaaar caaar) (caaadr cdaadr caadr) (caadar cdadar cadar)
- (caaddr cdaddr caddr) (cadaar cddaar cdaar) (cadadr cddadr cdadr) (caddar cdddar cddar)))))
- (and x
- (eq? (cadr x) (caaddr form))
- (caddr x))))
- => (lambda (cfunc)
- (if (and cfunc
- (equal? (cadadr form) (cadr (caddr form)))
- (not (side-effect? (cadadr form) env)))
- (lint-format "perhaps ~A" caller (lists->string form
- (if (symbol? cfunc)
- `(copy (,cfunc ,(cadadr form)))
- `(copy ,(cadadr form))))))))
-
- ((and (pair? (caddr form)) ; (cons a (cons b (cons ...))) -> (list a b ...), input ending in nil of course
- (eq? (caaddr form) 'cons))
- (let loop ((args (list (cadr form))) (chain (caddr form)))
- (if (and (pair? chain)
- (eq? (car chain) 'cons)
- (pair? (cdr chain))
- (pair? (cddr chain)))
- (if (or (null? (caddr chain))
- (quoted-null? (caddr chain)))
- (begin
- (lint-format "perhaps ~A" caller (lists->string form `(list ,@(reverse args) ,(cadr chain))))
- (set! last-cons-line-number line-number))
- (if (pair? (caddr chain))
- (if (eq? (caaddr chain) 'cons)
- (loop (cons (cadr chain) args) (caddr chain))
- (if (eq? (caaddr chain) 'list)
- (begin
- (lint-format "perhaps ~A" caller (lists->string form `(list ,@(reverse args) ,(cadr chain) ,@(cdaddr chain))))
- (set! last-cons-line-number line-number))))))))))))
-
- ;; ----------------
- ((append)
- (unless (= line-number last-checker-line-number)
- (set! last-checker-line-number line-number)
- (letrec ((splice-append (lambda (lst)
- (cond ((null? lst)
- ())
- ((not (pair? lst))
- lst)
- ((and (pair? (car lst))
- (eq? (caar lst) 'append))
- (if (null? (cdar lst))
- (if (null? (cdr lst)) ; (append) at end -> () to keep copy intact?
- (list ())
- (splice-append (cdr lst)))
- (append (splice-append (cdar lst)) (splice-append (cdr lst)))))
- ((or (null? (cdr lst))
- (not (or (null? (car lst))
- (quoted-null? (car lst))
- (and (pair? (car lst))
- (eq? (caar lst) 'list)
- (null? (cdar lst))))))
- (cons (car lst) (splice-append (cdr lst))))
- (else (splice-append (cdr lst)))))))
-
- (let ((new-args (splice-append (cdr form)))) ; (append '(1) (append '(2) '(3))) -> (append '(1) '(2) '(3))
- (let ((len1 (length new-args))
- (suggestion made-suggestion))
- (if (and (> len1 2)
- (null? (list-ref new-args (- len1 1)))
- (pair? (list-ref new-args (- len1 2)))
- (memq (car (list-ref new-args (- len1 2))) '(list cons append map string->list vector->list make-list)))
- (set-cdr! (list-tail new-args (- len1 2)) ()))
-
- (define (append->list . items)
- (let ((lst (list 'list)))
- (for-each
- (lambda (item)
- (set! lst (append lst (if (eq? (car item) 'list)
- (cdr item)
- (distribute-quote (cadr item))))))
- items)
- lst))
-
- (case len1
- ((0) ; (append) -> ()
- (lint-format "perhaps ~A" caller (lists->string form ())))
- ((1) ; (append x) -> x
- (lint-format "perhaps ~A" caller (lists->string form (car new-args))))
- ((2) ; (append (list x) ()) -> (list x)
- (let ((arg2 (cadr new-args))
- (arg1 (car new-args)))
- (cond ((or (null? arg2)
- (quoted-null? arg2)
- (equal? arg2 '(list))) ; (append x ()) -> (copy x)
- (lint-format "perhaps clearer: ~A" caller (lists->string form `(copy ,arg1))))
+ (lists->string form
+ (if (or (symbol? (caadr arg1))
+ (pair? (caadr arg1)))
+ `(cons ',(caadr arg1) ,arg2)
+ `(cons ,(caadr arg1) ,arg2)))))
+
+ ((not (equal? (cdr form) new-args))
+ (lint-format "perhaps ~A" caller (lists->string form `(append , at new-args)))))))
+ (else
+ (cond ((every? (lambda (item)
+ (and (pair? item)
+ (or (eq? (car item) 'list)
+ (quoted-undotted-pair? item))))
+ new-args)
+ (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args))))
- ((null? arg1) ; (append () x) -> x
- (lint-format "perhaps ~A" caller (lists->string form arg2)))
+ ((and (pair? (car new-args)) ; (append (list x) y (list z)) -> (cons x (append y (list z)))?
+ (eq? (caar new-args) 'list)
+ (null? (cddar new-args)))
+ (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadar new-args) (append ,@(cdr new-args))))))
- ((not (pair? arg1)))
-
- ((and (pair? arg2) ; (append (list x y) '(z)) -> (list x y 'z)
- (or (eq? (car arg1) 'list)
- (quoted-undotted-pair? arg1))
- (or (eq? (car arg2) 'list)
- (quoted-undotted-pair? arg2)))
- (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args))))
-
- ((and (eq? (car arg1) 'list) ; (append (list x) y) -> (cons x y)
- (pair? (cdr arg1))
- (null? (cddr arg1)))
- (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadr arg1) ,arg2))))
-
- ((and (eq? (car arg1) 'vector->list)
- (pair? arg2)
- (eq? (car arg2) 'vector->list))
- (lint-format "perhaps ~A" caller (lists->string form `(vector->list (append ,(cadr arg1) ,(cadr arg2))))))
-
+ ((let ((n-1 (list-ref new-args (- len1 2))))
+ (and (pair? n-1)
+ (eq? (car n-1) 'list)
+ (pair? (cdr n-1))
+ (null? (cddr n-1))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(append ,@(copy new-args (make-list (- len1 2)))
+ (cons ,(cadr (list-ref new-args (- len1 2)))
+ ,(list-ref new-args (- len1 1)))))))
((not (equal? (cdr form) new-args))
(lint-format "perhaps ~A" caller (lists->string form `(append , at new-args)))))))
- (else
- (if (every? (lambda (item)
- (and (pair? item)
- (or (eq? (car item) 'list)
- (quoted-undotted-pair? item))))
- new-args)
- (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args))))))
-
- (if (and (= made-suggestion suggestion)
- (not (equal? (cdr form) new-args)))
- (lint-format "perhaps ~A" caller (lists->string form `(append , at new-args)))))))))
-
- ;; ----------------
- ((apply)
- (when (pair? (cdr form))
- (let ((len (length form))
- (suggestion made-suggestion))
- (if (= len 2)
- (lint-format "perhaps ~A" caller (lists->string form (list (cadr form))))
- (if (not (or (<= len 2) ; it might be (apply)...
- (symbol? (cadr form))
- (applicable? (cadr form))))
- (lint-format "~S is not applicable: ~A" caller (cadr form) (truncated-list->string form))
- (let ((happy #f)
- (f (cadr form)))
- (unless (or (<= len 2)
- (any-macro? f env)
- (eq? f 'macroexpand)) ; handled specially (syntactic, not a macro)
-
- (when (and (symbol? f)
- (not (var-member f env)))
- (let ((func (symbol->value f *e*)))
- (if (procedure? func)
- (let ((ary (arity func)))
- (if (and (pair? ary)
- (> (- (length form) 3) (cdr ary))) ; last apply arg might be var=()
- (lint-format "too many arguments for ~A: ~A" caller f form))))))
-
- (let ((last-arg (form (- len 1))))
- (if (and (not (list? last-arg))
- (code-constant? last-arg))
- (lint-format "last argument should be a list: ~A" caller (truncated-list->string form))
- (if (= len 3)
- (let ((args (caddr form)))
- (if (identity? f) ; (apply (lambda (x) x) y) -> (car y)
- (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args
- (lists->string form `(car ,args)))
- (if (simple-lambda? f) ; (apply (lambda (x) (f x)) y) -> (f (car y))
- (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args
- (lists->string form (tree-subst (list 'car args) (caadr f) (caddr f))))))
-
- (cond ((eq? f 'list) ; (apply list x) -> x?
- (lint-format "perhaps ~A" caller (lists->string form args)))
-
- ((or (null? args) ; (apply f ()) -> (f)
- (quoted-null? args))
- (lint-format "perhaps ~A" caller (lists->string form (list f))))
+
+ (if (and (= made-suggestion suggestion)
+ (not (equal? (cdr form) new-args)))
+ (lint-format "perhaps ~A" caller (lists->string form `(append , at new-args)))))))))
+ (hash-table-set! h 'append sp-append))
+
+ ;; ---------------- apply ----------------
+ (let ()
+ (define (sp-apply caller head form env)
+ (when (pair? (cdr form))
+ (let ((len (length form))
+ (suggestion made-suggestion))
+ (if (= len 2)
+ (lint-format "perhaps ~A" caller (lists->string form (list (cadr form))))
+ (if (not (or (<= len 2) ; it might be (apply)...
+ (symbol? (cadr form))
+ (applicable? (cadr form))))
+ (lint-format "~S is not applicable: ~A" caller (cadr form) (truncated-list->string form))
+ (let ((happy #f)
+ (f (cadr form)))
+ (unless (or (<= len 2)
+ (any-macro? f env)
+ (eq? f 'macroexpand)) ; handled specially (syntactic, not a macro)
+
+ (when (and (symbol? f)
+ (not (var-member f env)))
+ (let ((func (symbol->value f *e*)))
+ (if (procedure? func)
+ (let ((ary (arity func)))
+ (when (pair? ary)
+ (if (> (- len 3) (cdr ary)) ; last apply arg might be var=()
+ (lint-format "too many arguments for ~A: ~A" caller f form))
+ (if (and (= len 3)
+ (= (car ary) 1)
+ (= (cdr ary) 1))
+ (lint-format "perhaps ~A" caller (lists->string form `(,f (car ,(caddr form)))))))))))
+
+ (let ((last-arg (form (- len 1))))
+ (if (and (not (list? last-arg))
+ (code-constant? last-arg))
+ (lint-format "last argument should be a list: ~A" caller (truncated-list->string form))
+ (if (= len 3)
+ (let ((args (caddr form)))
+ (if (identity? f) ; (apply (lambda (x) x) y) -> (car y)
+ (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args
+ (lists->string form `(car ,args)))
+ (if (simple-lambda? f) ; (apply (lambda (x) (f x)) y) -> (f (car y))
+ (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args
+ (lists->string form (tree-subst (list 'car args) (caadr f) (caddr f))))))
+
+ (cond ((eq? f 'list) ; (apply list x) -> x?
+ (lint-format "perhaps ~A" caller (lists->string form args)))
+
+ ((any-null? args) ; (apply f ()) -> (f)
+ (lint-format "perhaps ~A" caller (lists->string form (list f))))
+
+ ((not (pair? args)))
+
+ ((eq? (car args) 'list) ; (apply f (list a b)) -> (f a b)
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(cdr args)))))
+
+ ((and (eq? (car args) 'quote) ; (apply eq? '(a b)) -> (eq? 'a 'b)
+ (= suggestion made-suggestion))
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(distribute-quote (cadr args))))))
+
+ ((eq? (car args) 'cons) ; (apply f (cons a b)) -> (apply f a b)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? (caddr args))
+ (eq? (caaddr args) 'cons))
+ `(apply ,f ,(cadr args) ,@(cdaddr args))
+ `(apply ,f ,@(cdr args))))))
+
+ ((and (memq f '(string vector int-vector float-vector))
+ (memq (car args) '(reverse reverse!))) ; (apply vector (reverse x)) -> (reverse (apply vector x))
+ (lint-format "perhaps ~A" caller (lists->string form `(reverse (apply ,f ,(cadr args))))))
+
+ ((and (eq? f 'string-append) ; (apply string-append (map ...))
+ (eq? (car args) 'map))
+ (if (eq? (cadr args) 'symbol->string)
+ (lint-format "perhaps ~A" caller ; (apply string-append (map symbol->string ...))
+ (lists->string form `(format #f "~{~A~}" ,(caddr args))))
+ (if (simple-lambda? (cadr args))
+ (let ((body (caddr (cadr args))))
+ (if (and (pair? body)
+ (eq? (car body) 'string-append)
+ (= (length body) 3)
+ (or (and (string? (cadr body))
+ (eq? (caddr body) (caadr (cadr args))))
+ (and (string? (caddr body))
+ (eq? (cadr body) (caadr (cadr args))))))
+ (let ((str (string-append "~{"
+ (if (string? (cadr body)) (cadr body) "~A")
+ (if (string? (caddr body)) (caddr body) "~A")
+ "~}")))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(format #f ,str ,(caddr args))))))))))
+
+ ((and (eq? f 'string) ; (apply string (map char-downcase x)) -> (string-downcase (apply string x))
+ (eq? (car args) 'map)
+ (memq (cadr args) '(char-upcase char-downcase)))
+ (lint-format "perhaps, assuming ~A is a list, ~A" caller (caddr args)
+ (lists->string form `(,(if (eq? (cadr args) 'char-upcase)
+ 'string-upcase 'string-downcase)
+ (apply string ,(caddr args))))))
+
+ ((and (eq? f 'append) ; (apply append (map vector->list args)) -> (vector->list (apply append args))
+ (eq? (car args) 'map)
+ (eq? (cadr args) 'vector->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(vector->list (apply append ,@(cddr args))))))
+ ;; (apply append (map...)) is very common but changing it to
+ ;; (map (lambda (x) (apply values (f x))) ...) from (apply append (map f ...))
+ ;; is not an obvious win. The code is more complicated, and currently apply values
+ ;; copies its args (as do apply and append -- how many copies are there here?!
+
+ ((and (eq? (car args) 'append) ; (apply f (append (list ...)...)) -> (apply f ... ...)
+ (pair? (cadr args))
+ (eq? (caadr args) 'list))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(apply ,f ,@(cdadr args)
+ ,(if (null? (cddr args)) ()
+ (if (null? (cdddr args)) (caddr args)
+ `(append ,@(cddr args))))))))))
+ (begin ; len > 3
+ (when (and (pair? last-arg)
+ (eq? (car last-arg) 'list) ; (apply f y z (list a b)) -> (f y z a b)
+ (not (hash-table-ref syntaces f))) ; also not any-macro I presume
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,@(copy (cdr form) (make-list (- len 2)))
+ ,@(cdr last-arg)))))
+
+ ;; can't cleanly go from (apply write o p) to (write o (car p)) since p can be ()
+
+ (when (and (not happy)
+ (not (memq f '(define define* define-macro define-macro* define-bacro define-bacro* lambda lambda*)))
+ (any-null? last-arg)) ; (apply f ... ()) -> (f ...)
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(copy (cddr form) (make-list (- len 3))))))))))))))))))
+ (hash-table-set! h 'apply sp-apply))
+
+ ;; ---------------- format ----------------
+ (let ()
+ (define (sp-format caller head form env)
+ (if (< (length form) 3)
+ (begin
+ (cond ((< (length form) 2)
+ (lint-format "~A has too few arguments: ~A" caller head (truncated-list->string form)))
- ((not (pair? args)))
+ ((and (pair? (cadr form))
+ (eq? (caadr form) 'format))
+ (lint-format "redundant format: ~A" caller (truncated-list->string form)))
- ((eq? (car args) 'list) ; (apply f (list a b)) -> (f a b)
- (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(cdr args)))))
-
- ((and (eq? (car args) 'quote) ; (apply eq? '(a b)) -> (eq? 'a 'b)
- (= suggestion made-suggestion))
- (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(distribute-quote (cadr args))))))
-
- ((eq? (car args) 'cons) ; (apply f (cons a b)) -> (apply f a b)
- (lint-format "perhaps ~A" caller (lists->string form `(apply ,f ,@(cdr args)))))
-
- ((and (memq f '(string vector int-vector float-vector))
- (memq (car args) '(reverse reverse!))) ; (apply vector (reverse x)) -> (reverse (apply vector x))
- (lint-format "perhaps ~A" caller (lists->string form `(reverse (apply ,f ,(cadr args))))))
-
- ((and (eq? f 'string-append) ; (apply string-append (map ...))
- (eq? (car args) 'map))
- (if (eq? (cadr args) 'symbol->string)
- (lint-format "perhaps ~A" caller ; (apply string-append (map symbol->string ...))
- (lists->string form `(format #f "~{~A~}" ,(caddr args))))
- (if (simple-lambda? (cadr args))
- (let ((body (caddr (cadr args))))
- (if (and (pair? body)
- (eq? (car body) 'string-append)
- (= (length body) 3)
- (or (and (string? (cadr body))
- (eq? (caddr body) (caadr (cadr args))))
- (and (string? (caddr body))
- (eq? (cadr body) (caadr (cadr args))))))
- (let ((str (string-append "~{"
- (if (string? (cadr body)) (cadr body) "~A")
- (if (string? (caddr body)) (caddr body) "~A")
- "~}")))
- (lint-format "perhaps ~A" caller
- (lists->string form `(format #f ,str ,(caddr args))))))))))
+ ((and (code-constant? (cadr form))
+ (not (string? (cadr form))))
+ (lint-format "format with one argument takes a string: ~A" caller (truncated-list->string form)))
- ((and (eq? f 'append) ; (apply append (map vector->list args)) -> (vector->list (apply append args))
- (eq? (car args) 'map)
- (eq? (cadr args) 'vector->list))
- (lint-format "perhaps ~A" caller (lists->string form `(vector->list (apply append ,@(cddr args))))))
-
- ((and (eq? (car args) 'append) ; (apply f (append (list ...)...)) -> (apply f ... ...)
- (pair? (cadr args))
- (eq? (caadr args) 'list))
- (lint-format "perhaps ~A" caller
- (lists->string form `(apply ,f ,@(cdadr args)
- ,(if (null? (cddr args)) ()
- (if (null? (cdddr args)) (caddr args)
- `(append ,@(cddr args))))))))))
- (begin ; len > 3
- (when (and (pair? last-arg)
- (eq? (car last-arg) 'list) ; (apply f y z (list a b)) -> (f y z a b)
- (not (hash-table-ref syntaces f))) ; also not any-macro I presume
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(,@(copy (cdr form) (make-list (- len 2)))
- ,@(cdr last-arg)))))
-
- ;; can't cleanly go from (apply write o p) to (write o (car p)) since p can be ()
-
- (when (and (not happy)
- (not (memq f '(define define* define-macro define-macro* define-bacro define-bacro* lambda lambda*)))
- (or (null? last-arg)
- (quoted-null? last-arg))) ; (apply f ... ()) -> (f ...)
- (lint-format "perhaps ~A" caller (lists->string form `(,f ,@(copy (cddr form) (make-list (- len 3))))))))))))))))))
-
- ;; ----------------
- ((format snd-display)
- (if (< (length form) 3)
- (begin
- (cond ((< (length form) 2)
- (lint-format "~A has too few arguments: ~A" caller head (truncated-list->string form)))
- ((and (pair? (cadr form))
- (eq? (caadr form) 'format))
- (lint-format "redundant format: ~A" caller (truncated-list->string form)))
- ((and (code-constant? (cadr form))
- (not (string? (cadr form))))
- (lint-format "format with one argument takes a string: ~A" caller (truncated-list->string form)))
- ((and (not (cadr form))
- (string? (caddr form)))
- (lint-format "perhaps ~A" caller (lists->string form (caddr form)))))
- env)
-
- (let ((control-string (if (string? (cadr form)) (cadr form) (caddr form)))
- (args (if (string? (cadr form)) (cddr form) (cdddr form))))
-
- (define count-directives
- (let ((format-control-char (let ((chars (make-vector 256 #f)))
- (for-each
- (lambda (c)
- (vector-set! chars (char->integer c) #t))
- '(#\A #\S #\C #\F #\E #\G #\O #\D #\B #\X #\P #\N #\W #\, #\{ #\} #\* #\@
- #\a #\s #\c #\f #\e #\g #\o #\d #\b #\x #\p #\n #\w
- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
- chars)))
- (lambda (str caller form)
- (let ((curlys 0)
- (dirs 0)
- (pos (char-position #\~ str)))
- (when pos
- (let ((len (length str))
- (tilde-time #t))
- (do ((i (+ pos 1) (+ i 1)))
- ((>= i len))
- (let ((c (string-ref str i)))
- (if tilde-time
- (begin
- (when (and (= curlys 0)
- (not (memq c '(#\~ #\T #\t #\& #\% #\^ #\| #\newline #\}))) ; ~* consumes an arg
- (not (call-with-exit
- (lambda (return)
- (do ((k i (+ k 1)))
- ((= k len) #f)
- ;; this can be confused by pad chars in ~T
- (if (not (or (char-numeric? (string-ref str k))
- (char=? (string-ref str k) #\,)))
- (return (char-ci=? (string-ref str k) #\t))))))))
- ;; the possibilities are endless, so I'll stick to the simplest
- (if (not (vector-ref format-control-char (char->integer c)))
- (lint-format "unrecognized format directive: ~C in ~S, ~S" caller c str form))
- (set! dirs (+ dirs 1))
-
- ;; ~n so try to figure out how many args are needed (this is not complete)
- (when (char-ci=? c #\n)
- (let ((j (+ i 1)))
- (if (>= j len)
- (lint-format "missing format directive: ~S" caller str)
- (begin
- ;; if ,n -- add another, if then not T, add another
- (if (char=? (string-ref str j) #\,)
- (cond ((>= (+ j 1) len)
- (lint-format "missing format directive: ~S" caller str))
- ((char-ci=? (string-ref str (+ j 1)) #\n)
- (set! dirs (+ dirs 1))
- (set! j (+ j 2)))
- ((char-numeric? (string-ref str (+ j 1)))
- (set! j (+ j 2)))
- (else (set! j (+ j 1)))))
- (if (>= j len)
- (lint-format "missing format directive: ~S" caller str)
- (if (not (char-ci=? (string-ref str j) #\t))
- (set! dirs (+ dirs 1)))))))))
-
- (set! tilde-time #f)
- (case c
- ((#\{) (set! curlys (+ curlys 1)))
- ((#\}) (set! curlys (- curlys 1)))
- ((#\^ #\|)
- (if (zero? curlys)
- (lint-format "~A has ~~~C outside ~~{~~}?" caller str c))))
- (if (and (< (+ i 2) len)
- (member (substring str i (+ i 3)) '("%~&" "^~^" "|~|" "&~&" "\n~\n") string=?))
- (lint-format "~A in ~A could be ~A" caller
- (substring str (- i 1) (+ i 3))
- str
- (substring str (- i 1) (+ i 1)))))
- (begin
- (set! pos (char-position #\~ str i))
- (if pos
- (begin
- (set! tilde-time #t)
- (set! i pos))
- (set! i len))))))
-
- (if tilde-time
- (lint-format "~A control string ends in tilde: ~A" caller head (truncated-list->string form)))))
-
- (if (not (= curlys 0))
- (lint-format "~A has ~D unmatched ~A~A: ~A"
- caller head
- (abs curlys)
- (if (positive? curlys) "{" "}")
- (if (> curlys 1) "s" "")
- (truncated-list->string form)))
- dirs))))
-
- (when (and (eq? head 'format)
- (string? (cadr form)))
- (lint-format "please include the port argument to format, perhaps ~A" caller `(format () ,@(cdr form))))
-
- (if (any? (lambda (arg)
- (and (string? arg)
- (or (string-position "ERROR" arg)
- (string-position "WARNING" arg))))
- (cdr form))
- (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))
+ ((and (not (cadr form))
+ (string? (caddr form)))
+ (lint-format "perhaps ~A" caller (lists->string form (caddr form)))))
+ env)
+
+ (let ((control-string ((if (string? (cadr form)) cadr caddr) form))
+ (args ((if (string? (cadr form)) cddr cdddr) form)))
+
+ (define count-directives
+ (let ((format-control-char (let ((chars (make-vector 256 #f)))
+ (for-each
+ (lambda (c)
+ (vector-set! chars (char->integer c) #t))
+ '(#\A #\S #\C #\F #\E #\G #\O #\D #\B #\X #\P #\N #\W #\, #\{ #\} #\* #\@
+ #\a #\s #\c #\f #\e #\g #\o #\d #\b #\x #\p #\n #\w
+ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+ chars)))
+ (lambda (str caller form)
+ (let ((curlys 0)
+ (dirs 0)
+ (pos (char-position #\~ str)))
+ (when pos
+ (let ((len (length str))
+ (tilde-time #t))
+ (do ((i (+ pos 1) (+ i 1)))
+ ((>= i len))
+ (let ((c (string-ref str i)))
+ (if tilde-time
+ (begin
+ (when (and (= curlys 0)
+ (not (memv c '(#\~ #\T #\t #\& #\% #\^ #\| #\newline #\}))) ; ~* consumes an arg
+ (not (call-with-exit
+ (lambda (return)
+ (do ((k i (+ k 1)))
+ ((= k len) #f)
+ ;; this can be confused by pad chars in ~T
+ (if (not (or (char-numeric? (string-ref str k))
+ (char=? (string-ref str k) #\,)))
+ (return (char-ci=? (string-ref str k) #\t))))))))
+ ;; the possibilities are endless, so I'll stick to the simplest
+ (if (not (vector-ref format-control-char (char->integer c)))
+ (lint-format "unrecognized format directive: ~C in ~S, ~S" caller c str form))
+ (set! dirs (+ dirs 1))
+
+ ;; ~n so try to figure out how many args are needed (this is not complete)
+ (when (char-ci=? c #\n)
+ (let ((j (+ i 1)))
+ (if (>= j len)
+ (lint-format "missing format directive: ~S" caller str)
+ (begin
+ ;; if ,n -- add another, if then not T, add another
+ (if (char=? (string-ref str j) #\,)
+ (cond ((>= (+ j 1) len)
+ (lint-format "missing format directive: ~S" caller str))
+ ((char-ci=? (string-ref str (+ j 1)) #\n)
+ (set! dirs (+ dirs 1))
+ (set! j (+ j 2)))
+ ((char-numeric? (string-ref str (+ j 1)))
+ (set! j (+ j 2)))
+ (else (set! j (+ j 1)))))
+ (if (>= j len)
+ (lint-format "missing format directive: ~S" caller str)
+ (if (not (char-ci=? (string-ref str j) #\t))
+ (set! dirs (+ dirs 1)))))))))
+
+ (set! tilde-time #f)
+ (case c
+ ((#\{) (set! curlys (+ curlys 1)))
+ ((#\}) (set! curlys (- curlys 1)))
+ ((#\^ #\|)
+ (if (zero? curlys)
+ (lint-format "~A has ~~~C outside ~~{~~}?" caller str c))))
+ (if (and (< (+ i 2) len)
+ (member (substring str i (+ i 3)) '("%~&" "^~^" "|~|" "&~&" "\n~\n") string=?))
+ (lint-format "~A in ~A could be ~A" caller
+ (substring str (- i 1) (+ i 3))
+ str
+ (substring str (- i 1) (+ i 1)))))
+ (begin
+ (set! pos (char-position #\~ str i))
+ (if pos
+ (begin
+ (set! tilde-time #t)
+ (set! i pos))
+ (set! i len))))))
+
+ (if tilde-time
+ (lint-format "~A control string ends in tilde: ~A" caller head (truncated-list->string form)))))
+
+ (if (not (= curlys 0))
+ (lint-format "~A has ~D unmatched ~A~A: ~A"
+ caller head
+ (abs curlys)
+ (if (positive? curlys) "{" "}")
+ (if (> curlys 1) "s" "")
+ (truncated-list->string form)))
+ dirs))))
+
+ (when (and (eq? head 'format)
+ (string? (cadr form)))
+ (lint-format "please include the port argument to format, perhaps ~A" caller `(format () ,@(cdr form))))
+
+ (if (any? (lambda (arg)
+ (and (string? arg)
+ (or (string-position "ERROR" arg)
+ (string-position "WARNING" arg))))
+ (cdr form))
+ (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))
+
+ (if (not (string? control-string))
+ (if (not (proper-list? args))
+ (lint-format "~S looks suspicious" caller form))
+ (let ((ndirs (count-directives control-string caller form))
+ (nargs (if (list? args) (length args) 0)))
+ (let ((pos (char-position #\null control-string)))
+ (if (and pos (< pos (length control-string)))
+ (lint-format "#\\null in a format control string will confuse both lint and format: ~S in ~A" caller control-string form)))
+ (if (not (or (= ndirs nargs)
+ (tree-memq 'values form)))
+ (lint-format "~A has ~A arguments: ~A"
+ caller head
+ (if (> ndirs nargs) "too few" "too many")
+ (truncated-list->string form))
+ (if (and (not (cadr form))
+ (zero? ndirs)
+ (not (char-position #\~ control-string)))
+ (lint-format "~A could be ~S, (format is a no-op here)" caller (truncated-list->string form) (caddr form))))))
+
+ (when (pair? args)
+ (for-each
+ (lambda (a)
+ (if (pair? a)
+ (case (car a)
+ ((number->string)
+ (if (null? (cddr a))
+ (lint-format "format arg ~A could be ~A" caller a (cadr a))
+ (if (and (pair? (cddr a))
+ (integer? (caddr a))
+ (memv (caddr a) '(2 8 10 16)))
+ (if (= (caddr a) 10)
+ (lint-format "format arg ~A could be ~A" caller a (cadr a))
+ (lint-format "format arg ~A could use the format directive ~~~A and change the argument to ~A" caller a
+ (case (caddr a) ((2) "B") ((8) "O") (else "X"))
+ (cadr a))))))
+
+ ((symbol->string)
+ (lint-format "format arg ~A could be ~A" caller a (cadr a)))
+
+ ((make-string)
+ (lint-format "format arg ~A could use the format directive ~~NC and change the argument to ... ~A ~A ..." caller a
+ (cadr a) (if (char? (caddr a)) (format #f "~W" (caddr a)) (caddr a))))
+
+ ((string-append)
+ (lint-format "format appends strings, so ~A seems wasteful" caller a)))))
+ args)))))
+ (hash-table-set! h 'format sp-format))
+
+ ;; ---------------- error ----------------
+ (hash-table-set!
+ h 'error
+ (lambda (caller head form env)
+ (if (any? (lambda (arg)
+ (and (string? arg)
+ (or (string-position "ERROR" arg)
+ (string-position "WARNING" arg))))
+ (cdr form))
+ (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))))
+
+ ;; ---------------- sort! ----------------
+ (let ()
+ (define (sp-sort caller head form env)
+ (if (= (length form) 3)
+ (let ((func (caddr form)))
+ (if (memq func '(= eq? eqv? equal? string=? char=? string-ci=? char-ci=?))
+ (lint-format "sort! with ~A may hang: ~A" caller func (truncated-list->string form))
+ (if (symbol? func)
+ (let ((sig (procedure-signature (symbol->value func))))
+ (if (and (pair? sig)
+ (not (eq? 'boolean? (car sig)))
+ (not (and (pair? (car sig))
+ (memq 'boolean? (car sig)))))
+ (lint-format "~A is a questionable sort! function" caller func))))))))
+ (hash-table-set! h 'sort! sp-sort))
+
+ ;; ---------------- substring ----------------
+ (let ()
+ (define (sp-substring caller head form env)
+ (if (every? code-constant? (cdr form))
+ (catch #t
+ (lambda ()
+ (let ((val (eval form)))
+ (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val)))
+ (lambda (type info)
+ (lint-format "~A -> ~A" caller (truncated-list->string form) (apply format #f info))))
- (if (not (string? control-string))
- (if (not (proper-list? args))
- (lint-format "~S looks suspicious" caller form))
- (let ((ndirs (count-directives control-string caller form))
- (nargs (if (list? args) (length args) 0)))
- (let ((pos (char-position #\null control-string)))
- (if (and pos (< pos (length control-string)))
- (lint-format "#\\null in a format control string will confuse both lint and format: ~S in ~A" caller control-string form)))
- (if (not (or (= ndirs nargs)
- (tree-memq 'values form)))
- (lint-format "~A has ~A arguments: ~A"
- caller head
- (if (> ndirs nargs) "too few" "too many")
- (truncated-list->string form))
- (if (and (not (cadr form))
- (zero? ndirs)
- (not (char-position #\~ control-string)))
- (lint-format "~A could be ~S, (format is a no-op here)" caller (truncated-list->string form) (caddr form))))))
-
- (when (pair? args)
- (for-each
- (lambda (a)
- (if (pair? a)
- (case (car a)
- ((number->string)
- (if (null? (cddr a))
- (lint-format "format arg ~A could be ~A" caller a (cadr a))
- (if (and (pair? (cddr a))
- (integer? (caddr a))
- (memv (caddr a) '(2 8 10 16)))
- (if (= (caddr a) 10)
- (lint-format "format arg ~A could be ~A" caller a (cadr a))
- (lint-format "format arg ~A could use the format directive ~~~A and change the argument to ~A" caller a
- (case (caddr a) ((2) "B") ((8) "O") (else "X"))
- (cadr a))))))
-
- ((symbol->string)
- (lint-format "format arg ~A could be ~A" caller a (cadr a)))
-
- ((make-string)
- (lint-format "format arg ~A could use the format directive ~~NC and change the argument to ... ~A ~A ..." caller a
- (cadr a) (if (char? (caddr a)) (format #f "~W" (caddr a)) (caddr a))))
-
- ((string-append)
- (lint-format "format appends strings, so ~A seems wasteful" caller a)))))
- args)))))
-
- ;; ----------------
- ((error)
- (if (any? (lambda (arg)
- (and (string? arg)
- (or (string-position "ERROR" arg)
- (string-position "WARNING" arg))))
- (cdr form))
- (lint-format "There's no need to shout: ~A" caller (truncated-list->string form))))
-
- ;; ----------------
- ((sort!)
- (if (= (length form) 3)
- (let ((func (caddr form)))
- (if (memq func '(= eq? eqv? equal? string=? char=? string-ci=? char-ci=?))
- (lint-format "sort! with ~A may hang: ~A" caller func (truncated-list->string form))
- (if (symbol? func)
- (let ((sig (procedure-signature (symbol->value func))))
- (if (and (pair? sig)
- (not (eq? (car sig) 'boolean?)))
- (lint-format "~A is a questionable sort! function" caller func))))))))
-
- ;; ----------------
- ((substring)
- (if (every? code-constant? (cdr form))
- (catch #t
- (lambda ()
- (let ((val (eval form)))
- (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val)))
- (lambda (type info)
- (lint-format "~A -> ~A" caller (truncated-list->string form) (apply format #f info))))
-
- (let ((str (cadr form)))
- (if (and (pair? str)
- (eq? (car str) 'substring)
- (pair? (cddr form))
- (null? (cdddr form))
- (null? (cdddr str)))
+ (let ((str (cadr form)))
+ (when (and (pair? str)
+ (eq? (car str) 'substring)
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (null? (cdddr str)))
(lint-format "perhaps ~A" caller
(lists->string form
(if (and (integer? (caddr form))
(integer? (caddr str)))
`(substring ,(cadr str) ,(+ (caddr str) (caddr form)))
`(substring ,(cadr str) (+ ,(caddr str) ,(caddr form)))))))
- ;; end indices are complicated -- since this rarely happens, not worth the trouble
- (if (and (integer? (caddr form))
- (zero? (caddr form))
- (null? (cdddr form)))
- (lint-format "perhaps clearer: ~A" caller (lists->string form `(copy ,str))))
- (if (and (pair? (cdddr form))
- (equal? (caddr form) (cadddr form)))
- (lint-format "leaving aside errors, ~A is \"\"" caller form)))))
-
- ;; ----------------
- ((list-tail)
- (if (= (length form) 3)
- (if (eqv? (caddr form) 0)
- (lint-format "perhaps ~A" caller (lists->string form (cadr form)))
- (if (and (pair? (cadr form))
- (eq? (caadr form) 'list-tail))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (integer? (caddr form))
- (integer? (caddr (cadr form))))
- `(list-tail ,(cadadr form) ,(+ (caddr (cadr form)) (caddr form)))
- `(list-tail ,(cadadr form) (+ ,(caddr (cadr form)) ,(caddr form))))))))))
- ;; ----------------
- ((eq?)
- (if (< (length form) 3)
- (lint-format "eq? needs 2 arguments: ~A" caller (truncated-list->string form))
- (let* ((arg1 (cadr form))
- (arg2 (caddr form))
- (eq1 (eqf arg1 env))
- (eq2 (eqf arg2 env))
- (specific-op (and (eq? (cadr eq1) (cadr eq2))
- (not (memq (cadr eq1) '(eqv? equal?)))
- (cadr eq1))))
-
- (eval-constant-expression caller form)
-
- (if (or (eq? (car eq1) 'equal?)
- (eq? (car eq2) 'equal?))
- (lint-format "eq? should be equal?~A in ~S" caller (if specific-op (format #f " or ~A" specific-op) "") form)
- (if (or (eq? (car eq1) 'eqv?)
- (eq? (car eq2) 'eqv?))
- (lint-format "eq? should be eqv?~A in ~S" caller (if specific-op (format #f " or ~A" specific-op) "") form)))
-
- (let ((expr 'unset))
- (cond ((or (not arg1) ; (eq? #f x) -> (not x)
- (quoted-not? arg1))
- (set! expr (simplify-boolean `(not ,arg2) () () env)))
- ((or (not arg2) ; (eq? x #f) -> (not x)
- (quoted-not? arg2))
- (set! expr (simplify-boolean `(not ,arg1) () () env)))
- ((and (or (null? arg1) ; (eq? () x) -> (null? x)
- (quoted-null? arg1))
- (not (code-constant? arg2)))
- (set! expr (or (equal? arg2 '(list)) ; (eq? () (list)) -> #t
- `(null? ,arg2))))
- ((and (or (null? arg2) ; (eq? x ()) -> (null? x)
- (quoted-null? arg2))
- (not (code-constant? arg1)))
- (set! expr (or (equal? arg1 '(list))
- `(null? ,arg1))))
- ((and (eq? arg1 #t) ; (eq? #t <boolean-expr>) -> boolean-expr
- (pair? arg2)
- (eq? (return-type (car arg2) env) 'boolean?))
- (set! expr arg2))
- ((and (eq? arg2 #t) ; ; (eq? <boolean-expr> #t) -> boolean-expr
- (pair? arg1)
- (eq? (return-type (car arg1) env) 'boolean?))
- (set! expr arg1)))
- (if (not (eq? expr 'unset))
- (lint-format "perhaps ~A" caller (lists->string form expr)))))))
-
- ;; ----------------
- ((eqv? equal? morally-equal?)
- (if (< (length form) 3)
- (lint-format "~A needs 2 arguments: ~A" caller head (truncated-list->string form))
- (let* ((arg1 (cadr form))
- (arg2 (caddr form))
- (eq1 (eqf arg1 env))
- (eq2 (eqf arg2 env))
- (specific-op (and (eq? (cadr eq1) (cadr eq2))
- (not (memq (cadr eq1) '(eq? eqv? equal?)))
- (cadr eq1))))
-
- (eval-constant-expression caller form)
-
- (cond ((or (eq? (car eq1) 'equal?)
- (eq? (car eq2) 'equal?))
- (if (memq head '(equal? morally-equal?))
- (if specific-op
- (lint-format "~A could be ~A in ~S" caller head specific-op form))
- (lint-format "~A should be equal?~A in ~S" caller head
- (if specific-op (format #f " or ~A" specific-op) "")
- form)))
-
- ((or (eq? (car eq1) 'eqv?)
- (eq? (car eq2) 'eqv?))
- (if (memq head '(eqv? morally-equal?))
- (if specific-op
- (lint-format "~A could be ~A in ~S" caller head specific-op form))
- (lint-format "~A ~A be eqv?~A in ~S" caller head
- (if (eq? head 'eq?) "should" "could")
- (if specific-op (format #f " or ~A" specific-op) "")
- form)))
-
- ((not (or (eq? (car eq1) 'eq?)
- (eq? (car eq2) 'eq?))))
-
- ((not (and arg1 arg2))
- (lint-format "~A could be not: ~A" caller head (lists->string form `(not ,(or arg1 arg2)))))
-
- ((or (null? arg1)
- (null? arg2)
- (quoted-null? arg1) (quoted-null? arg2))
- (lint-format "~A could be null?: ~A" caller head
- (lists->string form
- (if (or (null? arg1) (quoted-null? arg1))
- `(null? ,arg2)
- `(null? ,arg1)))))
- ((not (eq? head 'eq?))
- (lint-format "~A could be eq?~A in ~S" caller head
- (if specific-op (format #f " or ~A" specific-op) "")
- form))))))
-
- ;; ----------------
- ((map for-each)
- (let* ((len (length form))
- (args (- len 2)))
- (if (< len 3)
- (lint-format "~A missing argument~A in: ~A"
- caller head
- (if (= len 2) "" "s")
- (truncated-list->string form))
- (let ((func (cadr form))
- (ary #f))
- (if (and (symbol? func)
- ;(defined? func)
- (procedure? (symbol->value func *e*)))
- (begin
- (set! ary (arity (symbol->value func *e*)))
- (if (and (eq? head 'map)
- (hash-table-ref no-side-effect-functions func)
- (= len 3)
- (pair? (caddr form))
- (or (eq? (caaddr form) 'quote)
- (and (eq? (caaddr form) 'list)
- (every? code-constant? (cdaddr form)))))
- (catch #t
- (lambda ()
- (let ((val (eval form)))
- (lint-format "perhaps ~A" caller (lists->string form (list 'quote val)))))
- (lambda args #f))))
+
+ ;; end indices are complicated -- since this rarely happens, not worth the trouble
+ (if (and (integer? (caddr form))
+ (zero? (caddr form))
+ (null? (cdddr form)))
+ (lint-format "perhaps clearer: ~A" caller (lists->string form `(copy ,str))))
+
+ (when (string? str) ; (substring "++++++" 0 2) -> (make-string 2 #\+)
+ (let ((len (length str)))
+ (when (and (> len 0)
+ (string=? str (make-string len (string-ref str 0))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((chars (if (null? (cddr form))
+ len
+ (if (pair? (cdddr form))
+ (if (eqv? (caddr form) 0)
+ (cadddr form)
+ `(- ,(cadddr form) ,(caddr form)))
+ `(- ,len ,(caddr form))))))
+ `(make-string ,chars ,(string-ref str 0))))))))
+ (when (pair? (cdddr form))
+ (let ((end (cadddr form)))
+ (if (equal? (caddr form) end)
+ (lint-format "leaving aside errors, ~A is \"\"" caller form))
- (if (and (pair? func)
- (memq (car func) '(lambda lambda*))
- (pair? (cadr func)))
- (let ((arglen (length (cadr func))))
- (set! ary (if (eq? (car func) 'lambda)
- (if (negative? arglen)
- (cons (abs arglen) 512000)
- (cons arglen arglen))
- (cons 0 (if (or (negative? arglen)
- (memq :rest (cadr func)))
- 512000 arglen)))))))
- (if (pair? ary)
- (if (< args (car ary))
- (lint-format "~A has too few arguments in: ~A"
- caller head
- (truncated-list->string form))
- (if (> args (cdr ary))
- (lint-format "~A has too many arguments in: ~A"
- caller head
- (truncated-list->string form)))))
- (for-each
- (lambda (obj)
- (if (and (pair? obj)
- (memq (car obj) '(vector->list string->list let->list)))
- (lint-format* caller
- (truncated-list->string obj)
- " could be simplified to: "
- (truncated-list->string (cadr obj))
- (string-append " ; (" (symbol->string head) " accepts non-list sequences)"))))
- (cddr form))
+ (when (and (pair? str)
+ (eqv? (caddr form) 0)
+ (eq? (car str) 'string-append)
+ (= (length str) 3))
+ (let ((in-arg2 (caddr str)))
+ (if (and (pair? in-arg2)
+ (eq? (car in-arg2) 'make-string)
+ (equal? (cadddr form) (cadr in-arg2)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(copy ,(cadr str) (make-string ,(cadddr form) ,(caddr in-arg2))))))))
+
+ (if (and (pair? end) ; (substring x start (length|string-length x)) -> (substring s start)
+ (memq (car end) '(string-length length))
+ (equal? (cadr end) str))
+ (lint-format "perhaps ~A" caller (lists->string form (copy form (make-list 3))))
+
+ (when (symbol? end)
+ (let ((v (var-member end env)))
+ (if (and (var? v)
+ (equal? `(string-length ,str) (var-initial-value v))
+ (not (any? (lambda (p)
+ (set!? p env))
+ (var-history v))))
+ (lint-format "perhaps, if ~A is still ~A, ~A" caller end (var-initial-value v)
+ (lists->string form (copy form (make-list 3)))))))))))))
+
+ (hash-table-set! h 'substring sp-substring))
+
+ ;; ---------------- list-tail ----------------
+ (let ()
+ (define (sp-list-tail caller head form env)
+ (if (= (length form) 3)
+ (if (eqv? (caddr form) 0)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr form)))
+ (if (and (pair? (cadr form))
+ (eq? (caadr form) 'list-tail))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (integer? (caddr form))
+ (integer? (caddr (cadr form))))
+ `(list-tail ,(cadadr form) ,(+ (caddr (cadr form)) (caddr form)))
+ `(list-tail ,(cadadr form) (+ ,(caddr (cadr form)) ,(caddr form))))))))))
+ (hash-table-set! h 'list-tail sp-list-tail))
+
+ ;; ---------------- eq? ----------------
+ (let ()
+ (define (sp-eq? caller head form env)
+ (if (< (length form) 3)
+ (lint-format "eq? needs 2 arguments: ~A" caller (truncated-list->string form))
+ (let* ((arg1 (cadr form))
+ (arg2 (caddr form))
+ (eq1 (eqf arg1 env))
+ (eq2 (eqf arg2 env))
+ (specific-op (and (eq? (cadr eq1) (cadr eq2))
+ (not (memq (cadr eq1) '(eqv? equal?)))
+ (cadr eq1))))
- (when (eq? head 'map)
- (when (and (memq func '(char-downcase char-upcase))
- (pair? (caddr form))
- (eq? (caaddr form) 'string->list))
- (lint-format "perhaps ~A" caller (lists->string form `(string->list (,(if (eq? func 'char-upcase) 'string-upcase 'string-downcase)
- ,(cadr (caddr form)))))))
- (when (identity? func) ; to check f here as var is more work
- (lint-format "perhaps ~A" caller (lists->string form (caddr form)))))
+ (eval-constant-expression caller form)
- (let ((arg1 (caddr form)))
- (when (and (pair? arg1)
- (memq (car arg1) '(cdr cddr cdddr cddddr list-tail))
- (pair? (cdr arg1))
- (pair? (cadr arg1))
- (memq (caadr arg1) '(string->list vector->list)))
- (let ((string-case (eq? (caadr arg1) 'string->list))
- (len-diff (if (eq? (car arg1) 'list-tail)
- (caddr arg1)
- (cdr-count (car arg1)))))
- (lint-format "~A accepts ~A arguments, so perhaps ~A" caller head
- (if string-case 'string 'vector)
- (lists->string arg1 (if string-case
- `(substring ,(cadadr arg1) ,len-diff)
- `(make-shared-vector ,(cadadr arg1) (- (length ,(cadadr arg1)) ,len-diff) ,len-diff)))))))
- (when (and (eq? head 'for-each)
- (pair? (cadr form))
- (eq? (caadr form) 'lambda)
- (pair? (cdadr form))
- (not (any? (lambda (x) (side-effect? x env)) (cddadr form))))
- (lint-format "pointless for-each: ~A" caller (truncated-list->string form)))
+ (if (or (eq? (car eq1) 'equal?)
+ (eq? (car eq2) 'equal?))
+ (lint-format "eq? should be equal?~A in ~S" caller (if specific-op (format #f " or ~A" specific-op) "") form)
+ (if (or (eq? (car eq1) 'eqv?)
+ (eq? (car eq2) 'eqv?))
+ (lint-format "eq? should be eqv?~A in ~S" caller (if specific-op (format #f " or ~A" specific-op) "") form)))
- (when (= args 1)
- (let ((seq (caddr form)))
-
- (when (pair? seq)
- (case (car seq)
- ((cons)
- (if (and (pair? (cdr seq))
- (pair? (cddr seq)))
- (if (or (null? (caddr seq))
- (quoted-null? (caddr seq)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (eq? head 'map)
- `(list (,(cadr form) ,(cadr seq)))
- `(,(cadr form) ,(cadr seq)))))
- (if (code-constant? (caddr seq))
- (lint-format "~A will ignore ~S in ~A" caller head (caddr seq) seq)))))
- ((list)
- (if (and (pair? (cdr seq))
- (null? (cddr seq)))
- (let* ((list-arg (cadr seq))
- (sig (and (pair? list-arg)
- (arg-signature seq env))))
- (if (not (or (and (pair? sig)
- (pair? (car sig))
- (memq 'values (car sig)))
- (tree-memq 'values list-arg)))
- (lint-format "~Aperhaps ~A" caller
- (if (or sig
- (not (pair? list-arg)))
- ""
- (format #f "assuming ~A does not return multiple values, " list-arg))
- (lists->string form
- (if (eq? head 'map)
- `(list (,(cadr form) ,list-arg))
- `(,(cadr form) ,list-arg))))))))
- ((map)
- (when (= (length seq) 3)
- ;; a toss-up -- probably faster to combine funcs here, and easier to read?
- ;; but only if first arg is only used once in first func, and everything is simple (one-line or symbol)
- (let* ((seq-func (cadr seq))
- (arg-name (find-unique-name func seq-func)))
-
- (if (symbol? func)
- (if (symbol? seq-func)
- ;; (map f (map g h)) -> (map (lambda (x) (f (g x))) h) -- dubious...
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head (lambda (,arg-name)
- (,func (,seq-func ,arg-name)))
- ,(caddr seq))))
- (if (simple-lambda? seq-func)
- ;; (map f (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h)
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head (lambda (,arg-name)
- (,func ,(tree-subst arg-name (caadr seq-func) (caddr seq-func))))
- ,(caddr seq))))))
- (if (less-simple-lambda? func)
- (if (symbol? seq-func)
- ;; (map (lambda (x) (f x)) (map g h)) -> (map (lambda (x) (f (g x))) h)
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head (lambda (,arg-name)
- ,@(tree-subst (list seq-func arg-name) (caadr func) (cddr func)))
- ,(caddr seq))))
- (if (simple-lambda? seq-func)
- ;; (map (lambda (x) (f x)) (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h)
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head (lambda (,arg-name)
- ,@(tree-subst (tree-subst arg-name (caadr seq-func) (caddr seq-func))
- (caadr func) (cddr func)))
- ,(caddr seq)))))))))))))
- ;; repetitive code...
- (when (eq? head 'for-each) ; args = 1 above
- (let ((func (cadr form)))
- (if (memq func '(display write newline write-char write-string))
- (lint-format "perhaps ~A" caller
- (if (and (pair? seq)
- (memq (car seq) '(list quote)))
- (let ((op (if (eq? func 'write) "~S" "~A"))
- (len (- (length seq) 1)))
- (lists->string form `(format () ,(do ((i 0 (+ i 1))
- (str ""))
- ((= i len) str)
- (set! str (string-append str op)))
- ,@(cdr seq))))
- (let ((op (if (eq? func 'write) "~{~S~}" "~{~A~}")))
- (lists->string form `(format () ,op ,seq)))))
- (when (and (pair? func)
- (eq? (car func) 'lambda))
- (let* ((body (cddr func))
- (op (write-port (car body)))
- (larg (and (pair? (cadr func))
- (caadr func))))
- (when (and (symbol? larg)
- (null? (cdadr func)) ; just one arg (one sequence to for-each) for now
- (every? (lambda (x)
- (and (pair? x)
- (memq (car x) '(display write newline write-char write-string))
- (or (eq? (car x) 'newline)
- (eq? (cadr x) larg)
- (string? (cadr x))
- (eqv? (cadr x) #\space)
- (and (pair? (cadr x))
- (pair? (cdadr x))
- (eq? (caadr x) 'number->string)
- (eq? (cadadr x) larg)))
- (eq? (write-port x) op)))
- body))
- ;; (for-each (lambda (x) (display x) (write-char #\space)) msg)
- ;; (for-each (lambda (elt) (display elt)) lst)
- (let ((ctrl-string "")
- (arg-ctr 0))
-
- (define* (gather-format str (arg :unset))
- (set! ctrl-string (string-append ctrl-string str)))
-
- (for-each
- (lambda (d)
- (if (or (memq larg d)
- (and (pair? (cdr d))
- (pair? (cadr d))
- (memq larg (cadr d))))
- (set! arg-ctr (+ arg-ctr 1)))
- (gather-format (display->format d)))
- body)
-
- (when (= arg-ctr 1)
- (lint-format "perhaps ~A" caller
- (lists->string form `(format ,op ,(string-append "~{" ctrl-string "~}") ,seq))))))))
- )))))))))
-
- ;; ----------------
- ((magnitude)
- (if (and (= (length form) 2)
- (memq (->lint-type (cadr form)) '(integer? rational? real?)))
- (lint-format "perhaps use abs here: ~A" caller form)))
-
- ;; ----------------
- ((open-input-file open-output-file)
- (if (and (pair? (cdr form))
- (pair? (cddr form))
- (string? (caddr form))
- (not (memv (string-ref (caddr form) 0) '(#\r #\w #\a)))) ; b + then e m c x if gcc
- (lint-format "unexpected mode: ~A" caller form)))
-
- ;; ----------------
- ((values)
- (if (member 'values (cdr form) (lambda (a b)
- (and (pair? b)
- (eq? (car b) 'values))))
- (lint-format "perhaps ~A" caller (lists->string form `(values ,@(splice-if (lambda (x) (eq? x 'values)) (cdr form)))))
- (if (= (length form) 2)
- (lint-format "perhaps ~A" caller (lists->string form (cadr form))))))
-
- ;; ----------------
- ((call-with-values) ; (call/values p c) -> (c (p))
- (when (= (length form) 3)
- (let ((producer (cadr form))
- (consumer (caddr form)))
- (let* ((produced-values (mv-range producer env))
- (consumed-values (and produced-values
- (or (and (symbol? consumer)
- (arg-arity consumer env))
- (and (pair? consumer)
- (eq? (car consumer) 'lambda)
- (pair? (cadr consumer))
- (let ((len (length (cadr consumer))))
- (if (negative? len)
- (cons (abs len) (cdr (arity +))) ; 536870912 = MAX_ARITY in s7.c
- (cons len len))))))))
- (if (and consumed-values
- (or (> (car consumed-values) (car produced-values))
- (< (cdr consumed-values) (cadr produced-values))))
- (let ((clen ((if (> (car consumed-values) (car produced-values)) car cdr) consumed-values)))
- (lint-format "call-with-values consumer ~A wants ~D value~P, but producer ~A returns ~A"
- caller
- (truncated-list->string consumer)
- clen clen
- (truncated-list->string producer)
- ((if (> (car consumed-values) (car produced-values)) car cadr) produced-values)))))
-
- (cond ((not (pair? producer))
- (if (and (symbol? producer)
- (not (memq (return-type producer ()) '(#t #f values))))
- (lint-format "~A does not return multiple values" caller producer)
- (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer))))))
-
- ((not (eq? (car producer) 'lambda))
- (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer)))))
-
- ((pair? (cadr producer))
- (lint-format "~A requires too many arguments" caller (truncated-list->string producer)))
-
- ((symbol? (cadr producer))
- (lint-format "~A's parameter ~A will always be ()" caller (truncated-list->string producer) (cadr producer)))
+ (let ((expr 'unset))
+ (cond ((or (not arg1) ; (eq? #f x) -> (not x)
+ (quoted-not? arg1))
+ (set! expr (simplify-boolean `(not ,arg2) () () env)))
+
+ ((or (not arg2) ; (eq? x #f) -> (not x)
+ (quoted-not? arg2))
+ (set! expr (simplify-boolean `(not ,arg1) () () env)))
+
+ ((and (any-null? arg1) ; (eq? () x) -> (null? x)
+ (not (code-constant? arg2)))
+ (set! expr (or (equal? arg2 '(list)) ; (eq? () (list)) -> #t
+ `(null? ,arg2))))
+
+ ((and (any-null? arg2) ; (eq? x ()) -> (null? x)
+ (not (code-constant? arg1)))
+ (set! expr (or (equal? arg1 '(list))
+ `(null? ,arg1))))
+
+ ((and (eq? arg1 #t) ; (eq? #t <boolean-expr>) -> boolean-expr
+ (pair? arg2)
+ (eq? (return-type (car arg2) env) 'boolean?))
+ (set! expr arg2))
+
+ ((and (eq? arg2 #t) ; (eq? <boolean-expr> #t) -> boolean-expr
+ (pair? arg1)
+ (eq? (return-type (car arg1) env) 'boolean?))
+ (set! expr arg1)))
- ((and (pair? (cddr producer))
- (null? (cdddr producer)))
- (let ((body (caddr producer)))
- (if (or (code-constant? body)
- (and (pair? body)
- (symbol? (car body))
- (not (memq (return-type (car body) ()) '(#t #f values)))))
- (lint-format "~A does not return multiple values" caller body)
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (pair? body)
- (eq? (car body) 'values))
- `(,consumer ,@(cdr body))
- `(,consumer ,body)))))))
+ (if (not (eq? expr 'unset))
+ (lint-format "perhaps ~A" caller (lists->string form expr)))))))
+ (hash-table-set! h 'eq? sp-eq?))
+
+ ;; ---------------- eqv? equal? morally-equal? ----------------
+ (let ()
+ (define (sp-eqv? caller head form env)
+ (if (< (length form) 3)
+ (lint-format "~A needs 2 arguments: ~A" caller head (truncated-list->string form))
+ (let* ((arg1 (cadr form))
+ (arg2 (caddr form))
+ (eq1 (eqf arg1 env))
+ (eq2 (eqf arg2 env))
+ (specific-op (and (eq? (cadr eq1) (cadr eq2))
+ (not (memq (cadr eq1) '(eq? eqv? equal?)))
+ (cadr eq1))))
+
+ (eval-constant-expression caller form)
+
+ (if (and (string? (cadr form))
+ (= (length (cadr form)) 1))
+ (let ((s2 (caddr form)))
+ (if (pair? s2)
+ (if (eq? (car s2) 'string)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(char=? ,(string-ref (cadr form) 0) ,(cadr s2))))
+ (if (and (eq? (car s2) 'substring)
+ (= (length s2) 4)
+ (eqv? (list-ref s2 2) 0)
+ (eqv? (list-ref s2 3) 1))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(char=? ,(string-ref (cadr form) 0) (string-ref ,(cadr s2) 0)))))))))
+
+ (if (and (not (eq? (cadr eq1) (cadr eq2)))
+ (memq (cadr eq1) '(char=? string=?))
+ (memq (cadr eq2) '(char=? string=?)))
+ (lint-format "this can't be right: ~A" caller form))
+
+ ;; (equal? a (list b)) and equivalents happens a lot, but is the extra consing worse than
+ ;; (and (pair? a) (equal? (car a) b) (null? (cdr a))) -- code readability seems more important here
+
+ (cond ((or (eq? (car eq1) 'equal?)
+ (eq? (car eq2) 'equal?))
+ (if (eq? head 'equal?)
+ (if specific-op
+ (lint-format "~A could be ~A in ~S" caller head specific-op form))
+ (lint-format "~A should be equal?~A in ~S" caller head
+ (if specific-op (format #f " or ~A" specific-op) "")
+ form)))
+
+ ((or (eq? (car eq1) 'eqv?)
+ (eq? (car eq2) 'eqv?))
+ (if (eq? head 'eqv?)
+ (if specific-op
+ (lint-format "~A could be ~A in ~S" caller head specific-op form))
+ (lint-format "~A ~A be eqv?~A in ~S" caller head
+ (if (eq? head 'eq?) "should" "could")
+ (if specific-op (format #f " or ~A" specific-op) "")
+ form)))
+
+ ((not (or (eq? (car eq1) 'eq?)
+ (eq? (car eq2) 'eq?))))
+
+ ((not (and arg1 arg2))
+ (lint-format "~A could be not: ~A" caller head (lists->string form `(not ,(or arg1 arg2)))))
+
+ ((or (any-null? arg1)
+ (any-null? arg2))
+ (lint-format "~A could be null?: ~A" caller head
+ (lists->string form
+ (if (any-null? arg1)
+ `(null? ,arg2)
+ `(null? ,arg1)))))
+ (else
+ (lint-format "~A could be eq?~A in ~S" caller head
+ (if specific-op (format #f " or ~A" specific-op) "")
+ form))))))
+ (hash-table-set! h 'eqv? sp-eqv?)
+ (hash-table-set! h 'equal? sp-eqv?))
+
+ ;; ---------------- map for-each ----------------
+ (let ()
+ (define (sp-map caller head form env)
+ (let* ((len (length form))
+ (args (- len 2)))
+ (if (< len 3)
+ (lint-format "~A missing argument~A in: ~A"
+ caller head
+ (if (= len 2) "" "s")
+ (truncated-list->string form))
+ (let ((func (cadr form))
+ (ary #f))
+ (if (and (symbol? func)
+ (procedure? (symbol->value func *e*)))
+ (begin
+ (set! ary (arity (symbol->value func *e*)))
+ (if (and (eq? head 'map)
+ (hash-table-ref no-side-effect-functions func)
+ (= len 3)
+ (pair? (caddr form))
+ (or (eq? (caaddr form) 'quote)
+ (and (eq? (caaddr form) 'list)
+ (every? code-constant? (cdaddr form)))))
+ (catch #t
+ (lambda ()
+ (let ((val (eval form)))
+ (lint-format "perhaps ~A" caller (lists->string form (list 'quote val)))))
+ (lambda args #f))))
+
+ (when (and (pair? func)
+ (memq (car func) '(lambda lambda*)))
+ (if (pair? (cadr func))
+ (let ((arglen (length (cadr func))))
+ (set! ary (if (eq? (car func) 'lambda)
+ (if (negative? arglen)
+ (cons (abs arglen) 512000)
+ (cons arglen arglen))
+ (cons 0 (if (or (negative? arglen)
+ (memq :rest (cadr func)))
+ 512000 arglen))))))
+ (if (= len 3)
+ (let ((body (cddr func))) ; (map (lambda (a) #f) x) -> (make-list (abs (length x)) #f)
+ (if (and (null? (cdr body))
+ (code-constant? (car body)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(make-list (abs (length ,(caddr form))) ,(car body)))))))))
+ (if (pair? ary)
+ (if (< args (car ary))
+ (lint-format "~A has too few arguments in: ~A"
+ caller head
+ (truncated-list->string form))
+ (if (> args (cdr ary))
+ (lint-format "~A has too many arguments in: ~A"
+ caller head
+ (truncated-list->string form)))))
+ (for-each
+ (lambda (obj)
+ (if (and (pair? obj)
+ (memq (car obj) '(vector->list string->list let->list)))
+ (lint-format* caller
+ (truncated-list->string obj)
+ " could be simplified to: "
+ (truncated-list->string (cadr obj))
+ (string-append " ; (" (symbol->string head) " accepts non-list sequences)"))))
+ (cddr form))
+
+ (when (eq? head 'map)
+ (when (and (memq func '(char-downcase char-upcase))
+ (pair? (caddr form))
+ (eq? (caaddr form) 'string->list))
+ (lint-format "perhaps ~A" caller (lists->string form `(string->list (,(if (eq? func 'char-upcase) 'string-upcase 'string-downcase)
+ ,(cadr (caddr form)))))))
+ (when (identity? func) ; to check f here as var is more work
+ (lint-format "perhaps ~A" caller (lists->string form (caddr form)))))
+
+ (let ((arg1 (caddr form)))
+ (when (and (pair? arg1)
+ (memq (car arg1) '(cdr cddr cdddr cddddr list-tail))
+ (pair? (cdr arg1))
+ (pair? (cadr arg1))
+ (memq (caadr arg1) '(string->list vector->list)))
+ (let ((string-case (eq? (caadr arg1) 'string->list))
+ (len-diff (if (eq? (car arg1) 'list-tail)
+ (caddr arg1)
+ (cdr-count (car arg1)))))
+ (lint-format "~A accepts ~A arguments, so perhaps ~A" caller head
+ (if string-case 'string 'vector)
+ (lists->string arg1 (if string-case
+ `(substring ,(cadadr arg1) ,len-diff)
+ `(make-shared-vector ,(cadadr arg1) (- (length ,(cadadr arg1)) ,len-diff) ,len-diff)))))))
+ (when (and (eq? head 'for-each)
+ (pair? (cadr form))
+ (eq? (caadr form) 'lambda)
+ (pair? (cdadr form))
+ (not (any? (lambda (x) (side-effect? x env)) (cddadr form))))
+ (lint-format "pointless for-each: ~A" caller (truncated-list->string form)))
+
+ (when (= args 1)
+ (let ((seq (caddr form)))
+
+ (when (pair? seq)
+ (case (car seq)
+ ((cons)
+ (if (and (pair? (cdr seq))
+ (pair? (cddr seq)))
+ (if (any-null? (caddr seq))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? head 'map)
+ `(list (,(cadr form) ,(cadr seq)))
+ `(,(cadr form) ,(cadr seq)))))
+ (if (code-constant? (caddr seq))
+ (lint-format "~A will ignore ~S in ~A" caller head (caddr seq) seq)))))
+ ((list)
+ (if (and (pair? (cdr seq))
+ (null? (cddr seq)))
+ (let* ((list-arg (cadr seq))
+ (sig (and (pair? list-arg)
+ (arg-signature seq env))))
+ (if (not (or (and (pair? sig)
+ (pair? (car sig))
+ (memq 'values (car sig)))
+ (tree-memq 'values list-arg)))
+ (lint-format "~Aperhaps ~A" caller
+ (if (or sig
+ (not (pair? list-arg)))
+ ""
+ (format #f "assuming ~A does not return multiple values, " list-arg))
+ (lists->string form
+ (if (eq? head 'map)
+ `(list (,(cadr form) ,list-arg))
+ `(,(cadr form) ,list-arg))))))))
+ ((map)
+ (when (= (length seq) 3)
+ ;; a toss-up -- probably faster to combine funcs here, and easier to read?
+ ;; but only if first arg is only used once in first func, and everything is simple (one-line or symbol)
+ (let* ((seq-func (cadr seq))
+ (arg-name (find-unique-name func seq-func)))
+
+ (if (symbol? func)
+ (if (symbol? seq-func)
+ ;; (map f (map g h)) -> (map (lambda (x) (f (g x))) h) -- dubious...
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ (,func (,seq-func ,arg-name)))
+ ,(caddr seq))))
+ (if (simple-lambda? seq-func)
+ ;; (map f (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ (,func ,(tree-subst arg-name (caadr seq-func) (caddr seq-func))))
+ ,(caddr seq))))))
+ (if (less-simple-lambda? func)
+ (if (symbol? seq-func)
+ ;; (map (lambda (x) (f x)) (map g h)) -> (map (lambda (x) (f (g x))) h)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ ,@(tree-subst (list seq-func arg-name) (caadr func) (cddr func)))
+ ,(caddr seq))))
+ (if (simple-lambda? seq-func)
+ ;; (map (lambda (x) (f x)) (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head (lambda (,arg-name)
+ ,@(tree-subst (tree-subst arg-name (caadr seq-func) (caddr seq-func))
+ (caadr func) (cddr func)))
+ ,(caddr seq)))))))))))))
+ ;; repetitive code...
+ (when (eq? head 'for-each) ; args = 1 above
+ (let ((func (cadr form)))
+ (if (memq func '(display write newline write-char write-string))
+ (lint-format "perhaps ~A" caller
+ (if (and (pair? seq)
+ (memq (car seq) '(list quote)))
+ (let ((op (if (eq? func 'write) "~S" "~A"))
+ (len (- (length seq) 1)))
+ (lists->string form `(format () ,(do ((i 0 (+ i 1))
+ (str ""))
+ ((= i len) str)
+ (set! str (string-append str op)))
+ ,@(cdr seq))))
+ (let ((op (if (eq? func 'write) "~{~S~}" "~{~A~}")))
+ (lists->string form `(format () ,op ,seq)))))
+ (when (and (pair? func)
+ (eq? (car func) 'lambda))
+ (let* ((body (cddr func))
+ (op (write-port (car body)))
+ (larg (and (pair? (cadr func))
+ (caadr func))))
+ (when (and (symbol? larg)
+ (null? (cdadr func)) ; just one arg (one sequence to for-each) for now
+ (every? (lambda (x)
+ (and (pair? x)
+ (memq (car x) '(display write newline write-char write-string))
+ (or (eq? (car x) 'newline)
+ (eq? (cadr x) larg)
+ (string? (cadr x))
+ (eqv? (cadr x) #\space)
+ (and (pair? (cadr x))
+ (pair? (cdadr x))
+ (eq? (caadr x) 'number->string)
+ (eq? (cadadr x) larg)))
+ (eq? (write-port x) op)))
+ body))
+ ;; (for-each (lambda (x) (display x) (write-char #\space)) msg)
+ ;; (for-each (lambda (elt) (display elt)) lst)
+ (let ((ctrl-string "")
+ (arg-ctr 0))
+
+ (define* (gather-format str (arg :unset))
+ (set! ctrl-string (string-append ctrl-string str)))
+
+ (for-each
+ (lambda (d)
+ (if (or (memq larg d)
+ (and (pair? (cdr d))
+ (pair? (cadr d))
+ (memq larg (cadr d))))
+ (set! arg-ctr (+ arg-ctr 1)))
+ (gather-format (display->format d)))
+ body)
+
+ (when (= arg-ctr 1)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(format ,op ,(string-append "~{" ctrl-string "~}") ,seq))))))))
+ )))))))))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-map))
+ '(map for-each)))
+
+ ;; ---------------- magnitude ----------------
+ (hash-table-set!
+ h 'magnitude
+ (lambda (caller head form env)
+ (if (and (= (length form) 2)
+ (memq (->lint-type (cadr form)) '(integer? rational? real?)))
+ (lint-format "perhaps use abs here: ~A" caller form))))
+
+ ;; ---------------- open-input-file open-output-file ----------------
+ (let ()
+ (define (sp-open-input-file caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cddr form))
+ (string? (caddr form))
+ (not (memv (string-ref (caddr form) 0) '(#\r #\w #\a)))) ; b + then e m c x if gcc
+ (lint-format "unexpected mode: ~A" caller form)))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-open-input-file))
+ '(open-input-file open-output-file)))
+
+ ;; ---------------- values ----------------
+ (hash-table-set!
+ h 'values
+ (lambda (caller head form env)
+ (if (member 'values (cdr form) (lambda (a b)
+ (and (pair? b)
+ (eq? (car b) 'values))))
+ (lint-format "perhaps ~A" caller (lists->string form `(values ,@(splice-if (lambda (x) (eq? x 'values)) (cdr form)))))
+ (if (= (length form) 2)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr form)))))))
+
+ ;; ---------------- call-with-values ----------------
+ (let ()
+ (define (sp-call/values caller head form env) ; (call/values p c) -> (c (p))
+ (when (= (length form) 3)
+ (let ((producer (cadr form))
+ (consumer (caddr form)))
+ (let* ((produced-values (mv-range producer env))
+ (consumed-values (and produced-values
+ (or (and (symbol? consumer)
+ (arg-arity consumer env))
+ (and (pair? consumer)
+ (eq? (car consumer) 'lambda)
+ (pair? (cadr consumer))
+ (let ((len (length (cadr consumer))))
+ (if (negative? len)
+ (cons (abs len) (cdr (arity +))) ; 536870912 = MAX_ARITY in s7.c
+ (cons len len))))))))
+ (if (and consumed-values
+ (or (> (car consumed-values) (car produced-values))
+ (< (cdr consumed-values) (cadr produced-values))))
+ (let ((clen ((if (> (car consumed-values) (car produced-values)) car cdr) consumed-values)))
+ (lint-format "call-with-values consumer ~A wants ~D value~P, but producer ~A returns ~A"
+ caller
+ (truncated-list->string consumer)
+ clen clen
+ (truncated-list->string producer)
+ ((if (> (car consumed-values) (car produced-values)) car cadr) produced-values)))))
+
+ (cond ((not (pair? producer))
+ (if (and (symbol? producer)
+ (not (memq (return-type producer ()) '(#t #f values))))
+ (lint-format "~A does not return multiple values" caller producer)
+ (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer))))))
+
+ ((not (eq? (car producer) 'lambda))
+ (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer)))))
+
+ ((pair? (cadr producer))
+ (lint-format "~A requires too many arguments" caller (truncated-list->string producer)))
+
+ ((symbol? (cadr producer))
+ (lint-format "~A's parameter ~A will always be ()" caller (truncated-list->string producer) (cadr producer)))
+
+ ((and (pair? (cddr producer))
+ (null? (cdddr producer)))
+ (let ((body (caddr producer)))
+ (if (or (code-constant? body)
+ (and (pair? body)
+ (symbol? (car body))
+ (not (memq (return-type (car body) ()) '(#t #f values)))))
+ (lint-format "~A does not return multiple values" caller body)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? body)
+ (eq? (car body) 'values))
+ `(,consumer ,@(cdr body))
+ `(,consumer ,body)))))))
+
+ (else (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer)))))))))
+ (hash-table-set! h 'call-with-values sp-call/values))
+
+ ;; ---------------- multiple-value-bind ----------------
+ (let ()
+ (define (sp-mvb caller head form env)
+ (when (>= (length form) 4)
+ (let ((vars (cadr form))
+ (producer (caddr form))
+ (body (cdddr form)))
+
+ (if (null? vars)
+ (lint-format "this multiple-value-bind is pointless; perhaps ~A" caller
+ (lists->string form
+ (if (side-effect? producer env)
+ `(begin ,producer , at body)
+ (if (null? (cdr body))
+ (car body)
+ `(begin , at body)))))
- (else (lint-format "perhaps ~A" caller (lists->string form `(,consumer (,producer)))))))))
-
- ;; ----------------
- ((multiple-value-bind)
- (when (= (length form) 4)
- (let ((vars (cadr form))
- (producer (caddr form))
- (body (cdddr form)))
-
- (if (null? vars)
- (lint-format "this multiple-value-bind is pointless; perhaps ~A" caller
- (lists->string form
- (if (side-effect? producer env)
- `(begin ,producer , at body)
- (if (null? (cdr body))
- (car body)
- `(begin , at body)))))
-
- (if (not (symbol? vars)) ; else any number of values is ok
+ (unless (symbol? vars) ; else any number of values is ok
(let ((vals (mv-range producer env))
(args (length vars)))
- (if (and vals
- (or (< args (car vals))
- (> args (cadr vals))))
+ (if (and (pair? vals)
+ (not (<= (car vals) args (cadr vals))))
(lint-format "multiple-value-bind wants ~D values, but ~A returns ~A"
caller args
(truncated-list->string producer)
- (if (< args (car vals)) (car vals) (cadr vals))))
+ ((if (< args (car vals)) car cadr) vals)))
(if (and (pair? producer)
(symbol? (car producer))
(not (memq (return-type (car producer) ()) '(#t #f values))))
(lint-format "~A does not return multiple values" caller (car producer))
- (if (and (null? (cdr body))
- (pair? (car body))
- (equal? vars (cdar body))
- (defined? (caar body))
- (equal? (arity (symbol->value (caar body))) (cons args args)))
- (lint-format "perhaps ~A" caller (lists->string form `(,(caar body) ,producer)))))))))))
-
- ;; ----------------
- ((let-values)
- (if (and (pair? (cdr form))
- (pair? (cadr form)))
- (if (null? (cdadr form)) ; just one set of vars
- (let ((call (caadr form)))
- (if (and (pair? call)
- (pair? (cdr call)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (null? (cdr body))
+ (pair? (car body))
+ (equal? vars (cdar body))
+ (defined? (caar body))
+ (equal? (arity (symbol->value (caar body))) (cons args args)))
+ `(,(caar body) ,producer)
+ `((lambda ,vars , at body) ,producer)))))))))))
+ (hash-table-set! h 'multiple-value-bind sp-mvb))
+
+ ;; ---------------- let-values ----------------
+ (let ()
+ (define (sp-let-values caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form)))
+ (if (null? (cdadr form)) ; just one set of vars
+ (let ((call (caadr form)))
+ (if (and (pair? call)
+ (pair? (cdr call)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `((lambda ,(car call)
+ ,@(cddr form))
+ ,(cadr call))))))
+ (if (every? pair? (cadr form))
(lint-format "perhaps ~A" caller
- (lists->string form
- `((lambda ,(car call)
- ,@(cddr form))
- ,(cadr call))))))
- (if (every? pair? (cadr form))
- (lint-format "perhaps ~A" caller
- (lists->string
- form
- `(with-let
- (apply sublet (curlet)
- (list ,@(map (lambda (v)
- `((lambda ,(car v)
- (values ,@(map (lambda (name)
- (values (symbol->keyword name) name))
- (args->proper-list (car v)))))
- ,(cadr v)))
- (cadr form))))
- ,@(cddr form))))))))
-
- ;; ----------------
- ((let*-values)
- (if (and (pair? (cdr form))
- (pair? (cadr form)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (let loop ((var-data (cadr form)))
- (let ((v (car var-data)))
- (if (and (pair? (car v)) ; just one var
- (null? (cdar v)))
- (if (null? (cdr var-data))
- `(let ((,(caar v) ,(cadr v))) ,@(cddr form))
- `(let ((,(caar v) ,(cadr v))) ,(loop (cdr var-data))))
- (if (null? (cdr var-data))
- `((lambda ,(car v) ,@(cddr form)) ,(cadr v))
- `((lambda ,(car v) ,(loop (cdr var-data))) ,(cadr v))))))))))
- ((define-values)
- (when (pair? (cdr form))
- (if (null? (cadr form))
- (lint-format "~A is pointless" caller (truncated-list->string form))
- (when (pair? (cddr form))
- (lint-format "perhaps ~A" caller
- (cond ((symbol? (cadr form))
- (lists->string form `(define ,(cadr form) (list ,(caddr form)))))
-
- ((and (pair? (cadr form))
- (null? (cdadr form)))
- (lists->string form `(define ,(caadr form) ,(caddr form))))
-
- (else
- (let-temporarily ((target-line-length 120))
- (truncated-lists->string form
- `(varlet (curlet)
- ((lambda ,(cadr form)
- (curlet))
- ,(caddr form))))))))))))
- ;; ----------------
- ((eval)
- (when (= (length form) 2)
- (let ((arg (cadr form)))
- (cond ((not (pair? arg))
+ (lists->string
+ form
+ `(with-let
+ (apply sublet (curlet)
+ (list ,@(map (lambda (v)
+ `((lambda ,(car v)
+ (values ,@(map (lambda (name)
+ (values (symbol->keyword name) name))
+ (args->proper-list (car v)))))
+ ,(cadr v)))
+ (cadr form))))
+ ,@(cddr form))))))))
+ (hash-table-set! h 'let-values sp-let-values))
+
+ ;; ---------------- let*-values ----------------
+ (hash-table-set!
+ h 'let*-values
+ (lambda (caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cadr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let loop ((var-data (cadr form)))
+ (let ((v (car var-data)))
+ (if (and (pair? (car v)) ; just one var
+ (null? (cdar v)))
+ (if (null? (cdr var-data))
+ `(let ((,(caar v) ,(cadr v))) ,@(cddr form))
+ `(let ((,(caar v) ,(cadr v))) ,(loop (cdr var-data))))
+ (if (null? (cdr var-data))
+ `((lambda ,(car v) ,@(cddr form)) ,(cadr v))
+ `((lambda ,(car v) ,(loop (cdr var-data))) ,(cadr v)))))))))))
+
+ ;; ---------------- define-values ----------------
+ (hash-table-set!
+ h 'define-values
+ (lambda (caller head form env)
+ (when (pair? (cdr form))
+ (if (null? (cadr form))
+ (lint-format "~A is pointless" caller (truncated-list->string form))
+ (when (pair? (cddr form))
+ (lint-format "perhaps ~A" caller
+ (cond ((symbol? (cadr form))
+ (lists->string form `(define ,(cadr form) (list ,(caddr form)))))
+
+ ((and (pair? (cadr form))
+ (null? (cdadr form)))
+ (lists->string form `(define ,(caadr form) ,(caddr form))))
+
+ (else
+ (let-temporarily ((target-line-length 120))
+ (truncated-lists->string form
+ `(varlet (curlet)
+ ((lambda ,(cadr form)
+ (curlet))
+ ,(caddr form)))))))))))))
+ ;; ---------------- eval ----------------
+ (let ()
+ (define (sp-eval caller head form env)
+ (case (length form)
+ ((2)
+ (let ((arg (cadr form)))
+ (if (not (pair? arg))
(if (not (symbol? arg))
- (lint-format "this eval is pointless; perhaps ~A" caller (lists->string form arg))))
-
- ((eq? (car arg) 'quote)
- (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))
-
- ((eq? (car arg) 'string->symbol)
- (lint-format "perhaps ~A" caller (lists->string form (string->symbol (cadr arg)))))
-
- ((and (eq? (car arg) 'with-input-from-string)
- (pair? (cdr arg))
- (pair? (cddr arg))
- (eq? (caddr arg) 'read))
- (lint-format "perhaps ~A" caller
- (lists->string form `(eval-string ,(cadr arg)))))
-
- ((and (eq? (car arg) 'read)
- (= (length arg) 2)
- (pair? (cadr arg))
- (eq? (caadr arg) 'open-input-string))
- (lint-format "perhaps ~A" caller (lists->string form `(eval-string ,(cadadr arg)))))))))
-
- ;; ----------------
- ((fill! string-fill! list-fill! vector-fill!)
- (if (= (length form) 5)
- (check-start-and-end caller head (cdddr form) form env)))
-
- ;; ----------------
- ((write-string)
- (if (= (length form) 4)
- (check-start-and-end caller head (cddr form) form env)))
-
- ;; ----------------
- ((string-length)
- (if (and (= (length form) 2)
- (string? (cadr form)))
- (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (string-length (cadr form)))))
-
- ;; ----------------
- ((vector-length)
- (if (and (= (length form) 2)
- (vector? (cadr form)))
- (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (vector-length (cadr form)))))
-
- ;; ----------------
- ((dynamic-wind)
- (when (= (length form) 4)
- (let ((init (cadr form))
- (body (caddr form))
- (end (cadddr form))
- (empty 0))
- ;; (equal? init end) as a mistake doesn't seem to happen
-
- (when (and (pair? init)
- (eq? (car init) 'lambda))
- (if (not (null? (cadr init)))
- (lint-format "dynamic-wind init function should be a thunk: ~A" caller init))
- (if (pair? (cddr init))
- (let ((last-expr (list-ref init (- (length init) 1))))
- (if (not (pair? last-expr))
- (if (null? (cdddr init))
- (set! empty 1))
- (unless (side-effect? last-expr env)
+ (lint-format "this eval is pointless; perhaps ~A" caller (lists->string form arg)))
+ (case (car arg)
+ ((quote)
+ (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))
+
+ ((string->symbol)
+ (if (string? (cadr arg))
+ (lint-format "perhaps ~A" caller (lists->string form (string->symbol (cadr arg))))))
+
+ ((with-input-from-string call-with-input-string)
+ (if (and (pair? (cdr arg))
+ (pair? (cddr arg))
+ (eq? (caddr arg) 'read))
+ (lint-format "perhaps ~A" caller (lists->string form `(eval-string ,(cadr arg))))))
+
+ ((read)
+ (if (and (= (length arg) 2)
+ (pair? (cadr arg))
+ (eq? (caadr arg) 'open-input-string))
+ (lint-format "perhaps ~A" caller (lists->string form `(eval-string ,(cadadr arg))))))
+
+ ((list)
+ (if (every? (lambda (p)
+ (or (symbol? p)
+ (code-constant? p)))
+ (cdr arg))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (map (lambda (p)
+ (if (and (pair? p)
+ (eq? (car p) 'quote))
+ (cadr p)
+ (if (code-constant? p)
+ p
+ (list 'eval p))))
+ (cdr arg))))))))))
+ ((3)
+ (let ((arg (cadr form))
+ (e (caddr form)))
+ (if (and (pair? arg)
+ (eq? (car arg) 'quote))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (symbol? (cadr arg))
+ `(,e ,arg)
+ `(with-let ,e ,@(unbegin (cadr arg)))))))))))
+ (hash-table-set! h 'eval sp-eval))
+
+ ;; ---------------- fill! etc ----------------
+ (let ()
+ (define (sp-fill! caller head form env)
+ (if (= (length form) 5)
+ (check-start-and-end caller head (cdddr form) form env)))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-fill!))
+ '(fill! string-fill! list-fill! vector-fill!)))
+
+ ;; ---------------- write-string ----------------
+ (hash-table-set!
+ h 'write-string
+ (lambda (caller head form env)
+ (if (= (length form) 4)
+ (check-start-and-end caller 'write-string (cddr form) form env))))
+
+ ;; ---------------- read-line ----------------
+ (hash-table-set!
+ h 'read-line
+ (lambda (caller head form env)
+ (if (and (= (length form) 3)
+ (code-constant? (caddr form))
+ (not (boolean? (caddr form))))
+ (lint-format "the third argument should be boolean (#f=default, #t=include trailing newline): ~A" caller form))))
+
+ ;; ---------------- string-length ----------------
+ (hash-table-set!
+ h 'string-length
+ (lambda (caller head form env)
+ (if (and (= (length form) 2)
+ (string? (cadr form)))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (string-length (cadr form))))))
+
+ ;; ---------------- vector-length ----------------
+ (hash-table-set!
+ h 'vector-length
+ (lambda (caller head form env)
+ (if (and (= (length form) 2)
+ (vector? (cadr form)))
+ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (vector-length (cadr form))))))
+
+ ;; ---------------- dynamic-wind ----------------
+ (let ()
+ (define (sp-dw caller head form env)
+ (when (= (length form) 4)
+ (let ((init (cadr form))
+ (body (caddr form))
+ (end (cadddr form))
+ (empty 0))
+ ;; (equal? init end) as a mistake doesn't seem to happen
+
+ (when (and (pair? init)
+ (eq? (car init) 'lambda))
+ (if (not (null? (cadr init)))
+ (lint-format "dynamic-wind init function should be a thunk: ~A" caller init))
+ (if (pair? (cddr init))
+ (let ((last-expr (list-ref init (- (length init) 1))))
+ (if (not (pair? last-expr))
(if (null? (cdddr init))
(set! empty 1))
- (lint-format "this could be omitted: ~A in ~A" caller last-expr init))))))
-
- (if (and (pair? body)
- (eq? (car body) 'lambda))
- (if (not (null? (cadr body)))
- (lint-format "dynamic-wind body function should be a thunk: ~A" caller body))
- (set! empty 3)) ; don't try to access body below
-
- (when (and (pair? end)
- (eq? (car end) 'lambda))
- (if (not (null? (cadr end)))
- (lint-format "dynamic-wind end function should be a thunk: ~A" caller end))
- (if (pair? (cddr end))
- (let ((last-expr (list-ref end (- (length end) 1))))
- (if (not (pair? last-expr))
- (if (null? (cdddr end))
- (set! empty (+ empty 1)))
- (unless (side-effect? last-expr env) ; or if no side-effects in any (also in init)
+ (unless (side-effect? last-expr env)
+ (if (null? (cdddr init))
+ (set! empty 1))
+ (lint-format "this could be omitted: ~A in ~A" caller last-expr init))))))
+
+ (if (and (pair? body)
+ (eq? (car body) 'lambda))
+ (if (not (null? (cadr body)))
+ (lint-format "dynamic-wind body function should be a thunk: ~A" caller body))
+ (set! empty 3)) ; don't try to access body below
+
+ (when (and (pair? end)
+ (eq? (car end) 'lambda))
+ (if (not (null? (cadr end)))
+ (lint-format "dynamic-wind end function should be a thunk: ~A" caller end))
+ (if (pair? (cddr end))
+ (let ((last-expr (list-ref end (- (length end) 1))))
+ (if (not (pair? last-expr))
(if (null? (cdddr end))
(set! empty (+ empty 1)))
- (lint-format "this could be omitted: ~A in ~A" caller last-expr end)))
- (if (= empty 2)
- (lint-format "this dynamic-wind is pointless, ~A" caller
- (lists->string form (if (null? (cdddr body)) (caddr body) `(begin ,@(cddr body))))))))))))
-
- ;; ----------------
- ((*s7*)
- (if (= (length form) 2)
- (let ((arg (cadr form)))
- (if (and (pair? arg)
- (eq? (car arg) 'quote)
- (symbol? (cadr arg))
- (not (memq (cadr arg)
- '(print-length safety cpu-time heap-size free-heap-size gc-freed max-string-length max-list-length
- max-vector-length max-vector-dimensions default-hash-table-length initial-string-port-length
- gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults
- max-stack-size stack catches exits float-format-precision bignum-precision default-rationalize-error
- default-random-state morally-equal-float-epsilon hash-table-float-epsilon undefined-identifier-warnings
- gc-stats symbol-table-locked? c-objects history-size profile-info))))
- (lint-format "unknown *s7* field: ~A" caller arg)))))
-
- ((throw)
- (if (pair? (cdr form))
- (let* ((tag (cadr form))
- (eq (eqf tag env)))
- (if (not (member eq '((eq? eq?) (#t #t))))
- (lint-format "~A tag ~S is unreliable (catch uses eq? to match tags)" caller head tag)))))
-
- ((make-hash-table)
- (if (= (length form) 3)
- (let ((func (caddr form)))
- (if (and (symbol? func)
- (not (memq func '(eq? eqv? equal? morally-equal? char=? char-ci=? string=? string-ci=? =))))
- (lint-format "make-hash-table function, ~A, is not a hash function" caller func)))))
-
- ((null eq eqv equal) ; (null (cdr...))
- (if (not (var-member head env))
- (lint-format "misspelled '~A? in ~A?" caller head form)))
-
- ((interaction-environment the-environment) (lint-format "~A is probably curlet in s7" caller head))
- ((system-global-environment user-initial-environment) (lint-format "~A is probably rootlet in s7" caller head))
-; ((environment?) (lint-format "environment? is let? in s7" caller))
-; ((environment-set!) (lint-format "environment-set! is let-set! in s7" caller))
-; ((environment-ref) (lint-format "environment-ref is let-ref in s7" caller))
- ((unquote-splicing) (lint-format "unquote-splicing is probably (apply values ...) in s7" caller))
-
- ((bitwise-and bitwise-ior bitwise-not bitwise-xor)
- (if (not (var-member head env))
- (lint-format "~A is ~A in s7" caller head
- (cdr (assq head '((bitwise-and . logand) (bitwise-ior . logior) (bitwise-xor . logxor) (bitwise-not . lognot)))))))
-
- ((push!) ; not predefined
- (if (= (length form) 3)
- (set-set (caddr form) caller form env)))
-
- ((pop!) ; also not predefined
- (if (= (length form) 2)
- (set-set (cadr form) caller form env)))
-
- ((receive) ; this definition comes from Guile
- (if (and (> (length form) 3)
- (not (var-member 'receive env)))
- (check-special-cases caller 'call-with-values
- `(call-with-values
- (lambda () ,(caddr form))
- (lambda ,(cadr form) ,@(cdddr form)))
- env)))
- ((and-let*)
- (when (and (> (length form) 2)
- (not (var-member head env)))
- (let loop ((bindings (cadr form)))
- (cond ((pair? bindings)
- (if (binding-ok? caller head (car bindings) env #f)
- (loop (cdr bindings))))
- ((not (null? bindings))
- (lint-format "~A variable list is not a proper list? ~S" caller head bindings))
- ((and (pair? (cadr form)) ; (and-let* ((x (f y))) (abs x)) -> (cond ((f y) => abs))
- (null? (cdadr form))
- (pair? (cddr form)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (null? (cdddr form))
- (pair? (caddr form))
- (pair? (cdaddr form))
- (null? (cddr (caddr form)))
- (eq? (caaadr form) (cadr (caddr form))))
- `(cond (,(cadar (cadr form)) => ,(caaddr form)))
- `(cond (,(cadar (cadr form)) => (lambda (,(caaadr form)) ,@(cddr form))))))))))))
- )) ; end check-special-cases
+ (unless (side-effect? last-expr env) ; or if no side-effects in any (also in init)
+ (if (null? (cdddr end))
+ (set! empty (+ empty 1)))
+ (lint-format "this could be omitted: ~A in ~A" caller last-expr end)))
+ (if (= empty 2)
+ (lint-format "this dynamic-wind is pointless, ~A" caller
+ (lists->string form (if (null? (cdddr body)) (caddr body) `(begin ,@(cddr body))))))))))))
+ (hash-table-set! h 'dynamic-wind sp-dw))
+
+ ;; ---------------- *s7* ----------------
+ (hash-table-set!
+ h '*s7*
+ (let ((s7-fields (let ((h (make-hash-table)))
+ (for-each (lambda (f)
+ (hash-table-set! h f #t))
+ '(print-length safety cpu-time heap-size free-heap-size gc-freed max-string-length max-list-length
+ max-vector-length max-vector-dimensions default-hash-table-length initial-string-port-length
+ gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults
+ max-stack-size stack catches exits float-format-precision bignum-precision default-rationalize-error
+ default-random-state morally-equal-float-epsilon hash-table-float-epsilon undefined-identifier-warnings
+ gc-stats symbol-table-locked? c-objects history-size profile-info))
+ h)))
+ (lambda (caller head form env)
+ (if (= (length form) 2)
+ (let ((arg (cadr form)))
+ (if (and (pair? arg)
+ (eq? (car arg) 'quote)
+ (symbol? (cadr arg))
+ (not (hash-table-ref s7-fields (cadr arg))))
+ (lint-format "unknown *s7* field: ~A" caller arg)))))))
+
+ ;; ---------------- throw ----------------
+ (hash-table-set!
+ h 'throw
+ (lambda (caller head form env)
+ (if (pair? (cdr form))
+ (let* ((tag (cadr form))
+ (eq (eqf tag env)))
+ (if (not (member eq '((eq? eq?) (#t #t))))
+ (lint-format "~A tag ~S is unreliable (catch uses eq? to match tags)" caller 'throw tag))))))
+
+ ;; ---------------- make-hash-table ----------------
+ (hash-table-set!
+ h 'make-hash-table
+ (lambda (caller head form env)
+ (if (= (length form) 3)
+ (let ((func (caddr form)))
+ (if (and (symbol? func)
+ (not (memq func '(eq? eqv? equal? morally-equal? char=? char-ci=? string=? string-ci=? =))))
+ (lint-format "make-hash-table function, ~A, is not a hash function" caller func))))))
+
+ ;; ---------------- deprecated funcs ----------------
+ (let ((deprecated-ops '((global-environment . rootlet)
+ (current-environment . curlet)
+ (make-procedure-with-setter . dilambda)
+ (procedure-with-setter? . dilambda?)
+ (make-random-state . random-state))))
+
+ (define (sp-deprecate caller head form env)
+ (lint-format "~A is deprecated; use ~A" caller head (cond ((assq head deprecated-ops) => cdr))))
+
+ (for-each (lambda (op)
+ (hash-table-set! h (car op) sp-deprecate))
+ deprecated-ops))
+
+ ;; ---------------- eq null eqv equal ----------------
+ (let ()
+ (define (sp-null caller head form env)
+ (if (not (var-member head env))
+ (lint-format "misspelled '~A? in ~A?" caller head form)))
+ (for-each (lambda (f)
+ (hash-table-set! h f sp-null))
+ '(null eq eqv equal))) ; (null (cdr...))
+
+ ;; ---------------- string-index ----------------
+ (let ()
+ (define (sp-string-index caller head form env)
+ (if (and (pair? (cdr form))
+ (pair? (cddr form))
+ (not (var-member 'string-index env))
+ (or (char? (caddr form))
+ (let ((sig (arg-signature (caddr form) env)))
+ (and (pair? sig)
+ (eq? (car sig) 'char?)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(char-position ,(caddr form) ,(cadr form) ,@(cdddr form))))))
+ (hash-table-set! h 'string-index sp-string-index))
+
+ ;; ---------------- cons* ----------------
+ (let ()
+ (define (sp-cons* caller head form env)
+ (unless (var-member 'cons env)
+ (case (length form)
+ ((2) (lint-format "perhaps ~A" caller (lists->string form (cadr form))))
+ ((3) (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (any-null? (caddr form))
+ `(list ,(cadr form))
+ `(cons ,@(cdr form))))))
+ ((4) (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (any-null? (cadddr form))
+ `(list ,(cadr form) ,(caddr form))
+ `(cons ,(cadr form) (cons ,@(cddr form))))))))))
+ (hash-table-set! h 'cons* sp-cons*))
+
+ ;; ---------------- the-environment etc ----------------
+ (let ((other-names '((the-environment . curlet)
+ (interaction-environment . curlet)
+ (system-global-environment . rootlet)
+ (user-global-environment . rootlet)
+ (user-initial-environment . rootlet)
+ (procedure-environment . funclet)
+ (environment? . let?)
+ (environment-set! . let-set!)
+ (environment-ref . let-ref)
+ (fluid-let . let-temporarily)
+ (unquote-splicing apply values ...)
+ (bitwise-and . logand)
+ (bitwise-ior . logior)
+ (bitwise-xor . logxor)
+ (bitwise-not . lognot)
+ (arithmetic-shift . ash)
+ (vector-for-each . for-each)
+ (string-for-each . for-each)
+ (list-copy . copy)
+ (bytevector? . byte-vector?)
+ (bytevector . byte-vector)
+ (make-bytevector . make-byte-vector)
+ (bytevector-u8-ref . byte-vector-ref)
+ (bytevector-u8-set! . byte-vector-set!)
+ (bytevector-length . length)
+ (write-bytevector . write-string)
+ (exact-integer? . integer?)
+ (truncate-quotient . quotient)
+ (truncate-remainder . remainder)
+ (floor-remainder . modulo)
+ (read-u8 . read-byte)
+ (write-u8 . write-byte)
+ (write-simple . write)
+ (peek-u8 . peek-char)
+ (u8-ready? . char-ready?)
+ (open-input-bytevector . open-input-string)
+ (open-output-bytevector . open-output-string)
+ (raise . error)
+ (raise-continuable . error))))
+
+ (define (sp-other-names caller head form env)
+ (if (not (var-member head env))
+ (let ((counts (hash-table-ref other-names-counts head)))
+ (when (< (or counts 0) 3)
+ (hash-table-set! other-names-counts head (+ (or counts 0) 1))
+ (lint-format "~A is probably ~A in s7" caller head (cdr (assq head other-names)))))))
+
+ (for-each (lambda (f)
+ (hash-table-set! h (car f) sp-other-names))
+ other-names))
+
+ (hash-table-set!
+ h '1+
+ (lambda (caller head form env)
+ (if (not (var-member '1+ env))
+ (lint-format "perhaps ~A" caller (lists->string form `(+ ,(cadr form) 1))))))
+
+ (hash-table-set!
+ h '-1+
+ (lambda (caller head form env)
+ (if (not (var-member '-1+ env))
+ (lint-format "perhaps ~A" caller (lists->string form `(- ,(cadr form) 1))))))
+
+ ;; ---------------- push! pop! ----------------
+ (hash-table-set!
+ h 'push!
+ (lambda (caller head form env) ; not predefined
+ (if (= (length form) 3)
+ (set-set (caddr form) caller form env))))
+
+ (hash-table-set!
+ h 'pop!
+ (lambda (caller head form env) ; also not predefined
+ (if (= (length form) 2)
+ (set-set (cadr form) caller form env))))
+
+ ;; ---------------- receive ----------------
+ (hash-table-set!
+ h 'receive
+ (lambda (caller head form env) ; this definition comes from Guile
+ (if (and (> (length form) 3)
+ (not (var-member 'receive env)))
+ ((hash-table-ref h 'call-with-values)
+ caller 'call-with-values
+ `(call-with-values
+ (lambda () ,(caddr form))
+ (lambda ,(cadr form) ,@(cdddr form)))
+ env))))
+
+ ;; ---------------- and=> ----------------
+ (hash-table-set!
+ h 'and=>
+ (lambda (caller head form env)
+ (when (and (= (length form) 3)
+ (not (var-member 'and=> env)))
+ (lint-format "perhaps ~A" caller (lists->string form `(cond (,(cadr form) => ,(caddr form)) (else #f)))))))
+
+ ;; ---------------- and-let* ----------------
+ (hash-table-set!
+ h 'and-let*
+ (lambda (caller head form env)
+ (when (and (> (length form) 2)
+ (not (var-member 'and-let* env)))
+ (let loop ((bindings (cadr form)))
+ (cond ((pair? bindings)
+ (if (binding-ok? caller 'and-let* (car bindings) env #f)
+ (loop (cdr bindings))))
+ ((not (null? bindings))
+ (lint-format "~A variable list is not a proper list? ~S" caller 'and-let* bindings))
+ ((and (pair? (cadr form)) ; (and-let* ((x (f y))) (abs x)) -> (cond ((f y) => abs))
+ (null? (cdadr form))
+ (pair? (cddr form)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (null? (cdddr form))
+ (pair? (caddr form))
+ (pair? (cdaddr form))
+ (null? (cddr (caddr form)))
+ (eq? (caaadr form) (cadr (caddr form))))
+ `(cond (,(cadar (cadr form)) => ,(caaddr form)))
+ `(cond (,(cadar (cadr form)) => (lambda (,(caaadr form)) ,@(cddr form)))))))))))))
+ h))
- (define (prettify-checker-unq op)
- (if (pair? op)
- (string-append (prettify-checker-unq (car op)) " or " (prettify-checker-unq (cadr op)))
- (case op
- ((rational?) "rational")
- ((real?) "real")
- ((complex?) "complex")
- ((null?) "null")
- ((length) "a sequence")
- ((unspecified?) "untyped")
- (else
- (let ((op-name (symbol->string op)))
- (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ")
- (substring op-name 0 (- (length op-name) 1))))))))
-
- (define (prettify-checker op)
- (if (pair? op)
- (string-append (prettify-checker-unq (car op)) " or " (prettify-checker (cadr op)))
- (let ((op-name (symbol->string op)))
- (case op
- ((rational? real? complex? null?) op-name)
- ((unspecified?) "untyped")
- (else (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ") op-name))))))
(define (unused-parameter? x) #t)
(define (unused-set-parameter? x) #t)
@@ -6588,7 +7704,8 @@
(eq? (car arg) 'length)))) ; same for length
(if (and (pair? op)
(member checker op any-compatible?))
- (if (not (var-member :catch env))
+ (if (and *report-sloppy-assoc*
+ (not (var-member :catch env)))
(lint-format* caller
(string-append "in " (truncated-list->string form) ", ")
(string-append (symbol->string head) "'s argument " (prettify-arg-number arg-number))
@@ -6662,9 +7779,9 @@
((let let*)
(if (and (pair? (cdr tree))
(pair? (cddr tree)))
- (let ((vs (if (symbol? (cadr tree)) (caddr tree) (cadr tree))))
+ (let ((vs ((if (symbol? (cadr tree)) caddr cadr) tree)))
(if (not (any? (lambda (a) (or (not (pair? a)) (eq? sym (car a)))) vs))
- (fwalk sym (if (symbol? (cadr tree)) (cdddr tree) (cddr tree)))))))
+ (fwalk sym ((if (symbol? (cadr tree)) cdddr cddr) tree))))))
((do letrec letrec*)
(if (and (pair? (cdr tree))
@@ -6715,12 +7832,24 @@
(lambda (arg)
(let ((checker (check-checker (if (pair? checkers) (car checkers) checkers) (= arg-number flen))))
;; check-checker only fixes up :at-end cases
+
(define (check-arg expr)
(unless (symbol? expr)
(let ((op (->lint-type expr)))
(if (not (or (memq op '(#f #t values))
(every-compatible? checker op)))
(report-arg-trouble caller form head arg-number checker expr op)))))
+
+ (define (check-cond-arg expr)
+ (unless (symbol? expr)
+ (let ((op (->lint-type expr)))
+ (when (pair? op)
+ (set! op (remove 'boolean? op)) ; this is for cond test, no result -- returns test if not #f, so it can't be #f!
+ (if (null? (cdr op))
+ (set! op (car op))))
+ (if (not (or (memq op '(#f #t values))
+ (every-compatible? checker op)))
+ (report-arg-trouble caller form head arg-number checker expr op)))))
;; special case checker?
(if (and (symbol? checker)
@@ -6834,7 +7963,7 @@
(if (pair? (cdr clause))
(if (not (eq? (cadr clause) '=>))
(check-arg (list-ref clause (- (length clause) 1))))
- (check-arg (car clause)))))
+ (check-cond-arg (car clause)))))
(cdr arg)))
((call/cc call-with-exit call-with-current-continuation)
@@ -7104,9 +8233,9 @@
(unless (list? (fdata 'macro-ops))
(let ((syms (list () ())))
- (tree-symbol-walk (if (memq (fdata 'ftype) '(define-macro define-macro*))
- (cddr (fdata 'initial-value))
- (cdddr (fdata 'initial-value)))
+ (tree-symbol-walk ((if (memq (fdata 'ftype) '(define-macro define-macro*))
+ cddr cdddr)
+ (fdata 'initial-value))
syms)
(varlet fdata 'macro-locals (car syms) 'macro-ops (cadr syms))))
@@ -7242,44 +8371,20 @@
(lint-format "this looks odd: ~A" caller (truncated-list->string form))))
;; now try to check arg types
- (let* ((func (symbol->value head *e*))
- (arg-data (let ((sig (procedure-signature func)))
- (and (pair? sig)
- (cdr sig)))))
+ (let ((arg-data (cond ((procedure-signature (symbol->value head *e*)) => cdr) (else #f))))
(if (pair? arg-data)
(check-args caller head form arg-data env max-arity))
)))))))))))))
- (define (get-generator caller form env)
- (when (pair? (cdr form))
- (let ((name (if (pair? (cadr form))
- (caadr form)
- (cadr form))))
-
- (if (and (pair? (cadr form))
- (pair? (cdadr form)))
- (lint-walk caller (cdadr form) env))
-
- (let ((gen? (string->symbol (string-append (symbol->string name) "?")))
- (gen-make (string->symbol (string-append "make-" (symbol->string name)))))
- (list (make-fvar :name gen?
- :ftype 'define
- :decl (dummy-func 'define `(define (,gen? x) (let? x)) '(define (_ x) #f))
- :initial-value `(define (,gen? x) (let? x))
- :arglist (list 'x)
- :env env)
- (make-fvar :name gen-make
- :ftype 'define*
- :decl (dummy-func 'define* `(define* (,gen-make :rest x :allow-other-keys) (apply inlet x)) '(define (_ . x) #f))
- :initial-value `(define* (,gen-make :rest x :allow-other-keys) (apply inlet x))
- :arglist (list :rest 'x :allow-other-keys)
- :env env))))))
-
- (define (last-par x)
- (let ((len (length x)))
- (and (positive? len)
- (x (- len 1)))))
-
+ (define (indirect-set? vname func arg1)
+ (case func
+ ((set-car! set-cdr! vector-set! list-set! string-set!)
+ (eq? arg1 vname))
+ ((set!)
+ (and (pair? arg1)
+ (eq? (car arg1) vname)))
+ (else #f)))
+
(define (binding-ok? caller head binding env second-pass)
;; check let-style variable binding for various syntactic problems
(cond (second-pass
@@ -7344,15 +8449,6 @@
(var-history v))
base-type)))
- (define (indirect-set? vname func arg1)
- (case func
- ((set-car! set-cdr! vector-set! list-set! string-set!)
- (eq? arg1 vname))
- ((set!)
- (and (pair? arg1)
- (eq? (car arg1) vname)))
- (else #f)))
-
(define (bad-variable-name-numbered vname bad-names)
(let ((str (symbol->string vname)))
(let loop ((bads bad-names))
@@ -7384,8 +8480,7 @@
(truncated-list->string `(set! ,vn ,(var-initial-value (car cur))))))
(format #f "in the ~A body. Perhaps use set! instead: ~A"
head (truncated-list->string `(set! ,vn ,(var-initial-value (car cur)))))))
- (lint-format "~A ~A ~A is declared twice" caller
- head type vn)))))))))
+ (lint-format "~A ~A ~A is declared twice" caller head type vn)))))))))
(let ((old-line-number line-number))
@@ -7405,12 +8500,12 @@
(let ((setv #f)
(newv #f))
(if (string=? (substring vstr 0 4) "get-")
- (let ((sv (string->symbol (string-append "set-" (substring vstr 4)))))
+ (let ((sv (symbol "set-" (substring vstr 4))))
(set! setv (or (var-member sv vars)
(var-member sv env)))
(set! newv (string->symbol (substring vstr 4))))
(if (string=? (substring vstr (- len 4)) "-ref")
- (let ((sv (string->symbol (string-append (substring vstr 0 (- len 4)) "-set!"))))
+ (let ((sv (symbol (substring vstr 0 (- len 4)) "-set!")))
(set! setv (or (var-member sv vars)
(var-member sv env)))
(set! newv (string->symbol (substring vstr 0 (- len 4)))))
@@ -7419,8 +8514,8 @@
(let ((sv (string->symbol (let ((s (copy vstr))) (set! (s (+ pos 1)) #\s) s))))
(set! setv (or (var-member sv vars)
(var-member sv env)))
- (set! newv (string->symbol (string-append (substring vstr 0 pos)
- (substring vstr (+ pos 4)))))))))) ; +4 to include #\-
+ (set! newv (symbol (substring vstr 0 pos)
+ (substring vstr (+ pos 4))))))))) ; +4 to include #\-
(when (and setv
(not (var-member newv vars))
(not (var-member newv env)))
@@ -7455,11 +8550,11 @@
lint-left-margin #\space
caller
vname (var-name setv)
- lint-left-margin #\space
+ (+ lint-left-margin 4) #\space
vname getdots newv getdots
(var-name setv) setdots setvalue
newv setdots setvalue
- lint-left-margin #\space
+ (+ lint-left-margin 4) #\space
(lint-pp `(define ,newv (dilambda
(lambda ,getargs ,@(cddr getter))
(lambda ,setargs ,@(cddr setter))))))))))))))))))
@@ -7686,7 +8781,7 @@
(number? (var-initial-value local-var))
(eq? vname call-arg1)
(null? (cddr call))
- (hash-table-ref bools1 func))
+ (hash-table-ref booleans func))
(let ((val (catch #t
(lambda ()
((symbol->value func (rootlet)) (var-initial-value local-var)))
@@ -7721,7 +8816,8 @@
(memq (car init) '(make-vector make-float-vector make-int-vector
make-string make-list make-byte-vector))
(cadr init))))))
- (if (and lim (>= call-arg1 lim))
+ (if (and (real? lim)
+ (>= call-arg1 lim))
(lint-format "~A has length ~A, but index is ~A" caller vname lim call-arg1))))))))
(when (eq? func 'implicit-set)
@@ -7754,7 +8850,7 @@
(var-history local-var))
(let ((repeats ()))
(for-each (lambda (call)
- (if (and (> (cdr call) 5)
+ (if (and (> (cdr call) (max 3 (/ 20 (tree-leaves (car call))))) ; was 5
(not (memq (caar call) '(make-vector make-float-vector)))
(or (null? (cddar call))
(every? (lambda (p)
@@ -7763,9 +8859,7 @@
(cdar call))))
(set! repeats (cons (string-append (truncated-list->string (car call)) " occurs ")
(cons (string-append (object->string (cdr call)) " times"
- (if (pair? repeats)
- ", "
- ""))
+ (if (pair? repeats) ", " ""))
repeats)))))
h)
(if (pair? repeats)
@@ -7779,7 +8873,7 @@
(zero? (var-set local-var))
(memq (var-ftype local-var) '(define lambda))
(pair? (var-arglist local-var))
- (let loop ((calls (var-history local-var))) ; if func passed as arg, ignore it
+ (let loop ((calls (var-history local-var))) ; if func passed as arg, ignore it
(or (null? calls)
(null? (cdr calls))
(and (pair? (car calls))
@@ -7790,14 +8884,14 @@
((null? (cdr clauses))) ; ignore the initial value
(if (and (pair? (car clauses))
(eq? (caar clauses) (var-name local-var)))
- (for-each (lambda (arg par)
- (if (not (member arg (cdr par)))
- (set-cdr! par (cons arg (cdr par)))))
+ (for-each (lambda (arg par) ; collect all arguments for each parameter
+ (if (not (member arg (cdr par))) ; we haven't seen this argument yet, so
+ (set-cdr! par (cons arg (cdr par))))) ; add it to the list for this parameter
(cdar clauses)
pars)))
(for-each (lambda (p)
(if (and (pair? (cdr p))
- (null? (cddr p))
+ (null? (cddr p)) ; so all calls, this parameter has the same value
(not (symbol? (cadr p))))
(lint-format "~A's '~A parameter is always ~S (~D calls)" caller
(var-name local-var) (car p) (cadr p) (var-ref local-var))))
@@ -7820,13 +8914,13 @@
(pair? r2)
(pair? (cdr r1))
(pair? (cdr r2))
- (if (and (pair? (cadr r1))
- (pair? (cadr r2))
- (memq (caadr r1) '(let let* letrec letrec* do lambda lambda*
- define define-constant define-macro define-bacro define-expansion
- define* define-macro* define-bacro*)))
- (code-equal? (cadr r1) (cadr r2) mat e1 e2)
- (structures-equal? (cadr r1) (cadr r2) mat e1 e2))
+ ((if (and (pair? (cadr r1))
+ (pair? (cadr r2))
+ (memq (caadr r1) '(let let* letrec letrec* do lambda lambda*
+ define define-constant define-macro define-bacro define-expansion
+ define* define-macro* define-bacro*)))
+ code-equal? structures-equal?)
+ (cadr r1) (cadr r2) mat e1 e2)
(cons (car r1) (car r2))))
(let ((f1 (car p1))
@@ -7851,15 +8945,15 @@
(if (symbol? (car rest2))
(return #f)))
(and (= (length (car rest1)) (length (car rest2)))
- (structures-equal? (cdr rest1) (cdr rest2) ; refs in values are to outer matches
- (append (map (lambda (var1 var2)
+ (let ((new-matches (append (map (lambda (var1 var2)
(or (match-vars var1 var2 matches)
(return #f)))
(car rest1)
(car rest2))
- name ; append will splice out nil
- matches)
- e1 e2))))
+ name ; append will splice out nil
+ matches)))
+ (structures-equal? (cdr rest1) (cdr rest2) ; refs in values are to outer matches
+ new-matches e1 e2)))))
((let*) ; refs move with the vars
(and (= (length (car rest1)) (length (car rest2)))
(let ((new-matches matches))
@@ -7909,10 +9003,10 @@
(structures-equal? (cdr rest1) (cdr rest2)
(cons (cons (car rest1) (car rest2)) matches) e1 e2))
(and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
- (structures-equal? (cdr rest1) (cdr rest2)
- (append (map cons (proper-list (car rest1)) (proper-list (car rest2)))
- matches)
- e1 e2))))
+ (let ((new-matches (append (map cons (proper-list (car rest1)) (proper-list (car rest2)))
+ matches)))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2)))))
+
((define define-constant define-macro define-bacro define-expansion)
(if (symbol? (car rest1))
(and (symbol? (car rest2))
@@ -7920,10 +9014,9 @@
(and (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2)
new-matches)))
(and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
- (structures-equal? (cdr rest1) (cdr rest2)
- (append (map cons (proper-list (car rest1)) (proper-list (car rest2)))
- matches)
- e1 e2)
+ (let ((new-matches (append (map cons (proper-list (car rest1)) (proper-list (car rest2)))
+ matches)))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2))
(cons (cons (caar rest1) (caar rest2)) matches))))
;; for define we add the new name to matches before walking the body (shadow is immediate),
;; but then the new name is added to matches and returned (see below)
@@ -7935,8 +9028,7 @@
(cons (cons (car rest1) (car rest2)) matches)
e1 e2))
(and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
- (structures-equal? (cdr rest1) (cdr rest2)
- (append (map (lambda (a b)
+ (let ((new-matches (append (map (lambda (a b)
(if (or (pair? a) ; if default, both must have the same value
(pair? b))
(if (not (and (pair? a)
@@ -7946,8 +9038,8 @@
(cons (car a) (car b)))
(cons a b)))
(proper-list (car rest1)) (proper-list (car rest2)))
- matches)
- e1 e2))))
+ matches)))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2)))))
((define* define-macro* define-bacro*)
(if (symbol? (car rest1))
@@ -7956,8 +9048,7 @@
(and (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2)
new-matches)))
(and (eqv? (length (car rest1)) (length (car rest2))) ; (car rest2) might be a symbol, dotted lists ok here
- (structures-equal? (cdr rest1) (cdr rest2)
- (append (map (lambda (a b)
+ (let ((new-matches (append (map (lambda (a b)
(if (or (pair? a) ; if default, both must have the same value
(pair? b))
(if (not (and (pair? a)
@@ -7967,8 +9058,8 @@
(cons (car a) (car b)))
(cons a b)))
(proper-list (car rest1)) (proper-list (car rest2)))
- matches)
- e1 e2)
+ matches)))
+ (structures-equal? (cdr rest1) (cdr rest2) new-matches e1 e2))
(cons (cons (caar rest1) (caar rest2)) matches))))
(else #f))))))))) ; can't happen I hope
@@ -8036,7 +9127,7 @@
()
(if (eq? (car lst) :rest)
(cdr lst)
- (cons (if (pair? (car lst)) (caar lst) (car lst))
+ (cons ((if (pair? (car lst)) caar car) lst)
(if (pair? (cdr lst))
(proper-list* (cdr lst))
(if (null? (cdr lst))
@@ -8070,71 +9161,84 @@
(values)))
(proper-list* (var-arglist v))))))))
- (define find-code-match
- (let ((e1 ())
- (cutoff (max func-min-cutoff (- leaves 12))))
- (lambda (v)
- (and (not (eq? (var-name v) :lambda))
- (memq (var-ftype v) '(define lambda define* lambda*))
- (not (eq? caller (var-name v)))
- (let ((body (cddr (var-initial-value v)))
- (args (var-arglist v)))
- (set! e1 (var-env v))
-
- (let ((args-len (length args)))
- (when (or (eq? name-args-len :unset)
- (equal? args-len name-args-len)
- (and (integer? args-len)
- (integer? name-args-len)
- (not (negative? (* args-len name-args-len)))))
-
- (unless (var-leaves v)
- (set! (var-leaves v) (tree-leaves body))
- (set! (var-match-list v) (if (symbol? args)
- (list (cons args :unset))
- (map (lambda (arg)
- (if (symbol? arg)
- (cons arg :unset)
- (values)))
- (proper-list* args)))))
-
- ;; var-leaves is size of func (v) body
- ;; leaves is size of form which we want to match with func
- ;; func-min-cutoff avoids millions of uninteresting matches
-
- (and (<= cutoff (var-leaves v) leaves)
- (let ((match-list (do ((p (var-match-list v) (cdr p)))
- ((null? p)
- (var-match-list v))
- (set-cdr! (car p) :unset))))
- (and (structures-equal? body new-form
- (cons (cons (var-name v) caller) match-list) e1 e2)
- ;; if the functions are recursive, we also need those names matched, hence the extra entry
- ;; but we treat match-list below as just the args, so add the func names at the call,
- ;; but this can be fooled if we're playing games with eq? basically -- the function
- ;; names should only match if used as functions.
-
- (not (member :unset match-list (lambda (a b) (eq? (cdr b) :unset))))
- (let ((new-args (map cdr match-list)))
- (if (and (equal? new-args name-args)
- (equal? args-len name-args-len))
- (lint-format "~A could be ~A" caller caller `(define ,caller ,(var-name v)))
- (lint-format "perhaps ~A" caller (lists->string form `(,(var-name v) , at new-args))))
- #t)))))))))))
+ (let ((find-code-match
+ (let ((e1 ())
+ (cutoff (max func-min-cutoff (- leaves 12))))
+ (lambda (v)
+ (and (not (eq? (var-name v) :lambda))
+ (memq (var-ftype v) '(define lambda define* lambda*))
+ (not (eq? caller (var-name v)))
+ (let ((body (cddr (var-initial-value v)))
+ (args (var-arglist v)))
+ (set! e1 (var-env v))
+
+ (let ((args-len (length args)))
+ (when (or (eq? name-args-len :unset)
+ (equal? args-len name-args-len)
+ (and (integer? args-len)
+ (integer? name-args-len)
+ (not (negative? (* args-len name-args-len)))))
+
+ (unless (var-leaves v)
+ (set! (var-leaves v) (tree-leaves body))
+ (set! (var-match-list v) (if (symbol? args)
+ (list (cons args :unset))
+ (map (lambda (arg)
+ (if (symbol? arg)
+ (cons arg :unset)
+ (values)))
+ (proper-list* args)))))
+
+ ;; var-leaves is size of func (v) body
+ ;; leaves is size of form which we want to match with func
+ ;; func-min-cutoff avoids millions of uninteresting matches
+
+ (and (<= cutoff (var-leaves v) leaves)
+ (let ((match-list (do ((p (var-match-list v) (cdr p)))
+ ((null? p)
+ (var-match-list v))
+ (set-cdr! (car p) :unset))))
+ (and (structures-equal? body new-form
+ (cons (cons (var-name v) caller) match-list) e1 e2)
+ ;; if the functions are recursive, we also need those names matched, hence the extra entry
+ ;; but we treat match-list below as just the args, so add the func names at the call,
+ ;; but this can be fooled if we're playing games with eq? basically -- the function
+ ;; names should only match if used as functions.
+
+ (not (member :unset match-list (lambda (a b) (eq? (cdr b) :unset))))
+ (let ((new-args (map cdr match-list)))
+ (if (and (equal? new-args name-args)
+ (equal? args-len name-args-len))
+ (lint-format "~A could be ~A" caller caller `(define ,caller ,(var-name v)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(var-name v) , at new-args))))
+ #t))))))))))))
- (do ((vs (or (hash-table-ref equable-closures (caar new-form)) ()) (cdr vs)))
- ;; instead of hashing on car as above, hash on composite of cars+base statements
- ((or (null? vs)
- (find-code-match (car vs)))))))))
+ (do ((vs (or (hash-table-ref equable-closures (caar new-form)) ()) (cdr vs)))
+ ;; instead of hashing on car as above, hash on composite of cars+base statements
+ ((or (null? vs)
+ (find-code-match (car vs))))))))))
- (define (unbegin x)
- (if (and (pair? x)
- (eq? (car x) 'begin))
- (cdr x)
- (list x)))
+ (define (find-call sym body)
+ (call-with-exit
+ (lambda (return)
+ (let tree-call ((tree body))
+ (if (and (pair? tree)
+ (not (eq? (car tree) 'quote)))
+ (begin
+ (if (eq? (car tree) sym)
+ (return tree))
+ (if (memq (car tree) '(let let* letrec letrec* do lambda lambda* define))
+ (return #f)) ; possible shadowing -- not worth the infinite effort to corroborate
+ (if (pair? (car tree))
+ (tree-call (car tree)))
+ (if (pair? (cdr tree))
+ (do ((p (cdr tree) (cdr p)))
+ ((not (pair? p)) #f)
+ (tree-call (car p))))))))))
+
- (define (check-returns caller f env)
+ (define (check-returns caller f env) ; f is not the last form in the body
(if (not (or (side-effect? f env)
(eq? f '=>)))
(lint-format "this could be omitted: ~A" caller (truncated-list->string f))
@@ -8185,7 +9289,24 @@
(lint-format "this is pointless: ~A in ~A" caller
(truncated-list->string last-expr)
(truncated-list->string c)))))))
- (if (eq? (car f) 'cond) (cdr f) (cddr f))))
+ ((if (eq? (car f) 'cond) cdr cddr) f)))
+
+ ;; perhaps use truncated-lists->string here??
+ ((and)
+ (let ((len (length f)))
+ (case len
+ ((1) (lint-format "this ~A is pointless" caller f))
+ ((2) (lint-format "perhaps ~A" caller (lists->string f (cadr f))))
+ ((3) (lint-format "perhaps ~A" caller (lists->string f `(if ,(cadr f) ,(caddr f)))))
+ (else (lint-format "perhaps ~A" caller (lists->string f `(if ,(cadr f) (and ,@(cddr f)))))))))
+
+ ((or)
+ (let ((len (length f)))
+ (case len
+ ((1) (lint-format "this ~A is pointless" caller f))
+ ((2) (lint-format "perhaps ~A" caller (lists->string f (cadr f))))
+ ((3) (lint-format "perhaps ~A" caller (lists->string f `(if (not ,(cadr f)) ,(caddr f)))))
+ (else (lint-format "perhaps ~A" caller (lists->string f `(if (not ,(cadr f)) (or ,@(cddr f)))))))))
((let let*)
(if (and (pair? (cdr f))
@@ -8300,7 +9421,7 @@
(loop (cdr pars)
(if (pair? vals)
(values (cdr vals)
- (cons (list (if (pair? (car pars)) (caar pars) (car pars)) (car vals)) args))
+ (cons (list ((if (pair? (car pars)) caar car) pars) (car vals)) args))
(values ()
(cons (if (pair? (car pars)) (car pars) (list (car pars) #f)) args))))))))
(new-let (if (eq? (caar body) 'define) 'let 'let*)))
@@ -8317,10 +9438,178 @@
`(... ,@(tree-subst `(let () , at fbody) call (cdr body))))
`(... ,@(tree-subst `(let ,new-args , at fbody) call (cdr body))))
`(... ,@(tree-subst `(,new-let ,fname ,new-args , at fbody) call (cdr body))))))))))))
+ (when (pair? body)
+
+ ;; look for defines at the start of the body and use let(*) or letrec(*) instead
+ ;; we're in a closed body here, so the define can't propagate backwards
+ (when (and (pair? (car body))
+ (eq? (caar body) 'define)
+ (pair? (cdar body))
+ (symbol? (cadar body)))
+ (let ((names ())
+ (letx 'let)
+ (vars&vals ()))
+ (do ((p body (cdr p)))
+ ((not (and (pair? p)
+ (pair? (car p))
+ (eq? (caar p) 'define)
+ (symbol? (cadar p))))
+ (lint-format "perhaps ~A" caller
+ (lists->string `(... , at body)
+ `(... (,letx (,@(reverse vars&vals))
+ ...)))))
+ ;; define acts like letrec(*), not let -- reference to name in lambda body is current name
+ (let ((expr (car p)))
+ (set! vars&vals (cons (if (< (tree-leaves (cddr expr)) 12)
+ (cdr expr)
+ (list (cadr expr) '...))
+ vars&vals))
+ (if (tree-member (cadr expr) (cddr expr))
+ (set! letx (case letx ((let) 'letrec) ((let*) 'letrec*) (else letx))))
+ (if (tree-set-member names (cddr expr))
+ (set! letx (case letx ((let) 'let*) ((letrec) 'letrec*) (else letx))))
+ (set! names (cons (cadr expr) names))))))
+
+ (let ((len (length body)))
+ (when (> len 2) ; ... (define (x...)...) (x ...) -> (let (...) ...) or named let -- this happens a lot!
+ (let ((n-1 (list-ref body (- len 2))) ; or (define (x ...)...) (some expr calling x once) -> named let etc
+ (n (list-ref body (- len 1))))
+ (when (and (pair? n-1)
+ (eq? (car n-1) 'define)
+ (pair? (cadr n-1))
+ (symbol? (caadr n-1))
+ (proper-list? (cdadr n-1))
+ (pair? n)
+ (or (and (eq? (car n) (caadr n-1))
+ (eqv? (length (cdadr n-1)) (length (cdr n)))) ; not values -> let!
+ (and (< (tree-leaves n-1) 12)
+ (tree-car-member (caadr n-1) (cdr n)) ; skip car -- see preceding
+ (= (tree-count1 (caadr n-1) n 0) 1))))
+ (let ((outer-form (cond ((var-member :let env) => var-initial-value) (else #f)))
+ (new-var (caadr n-1)))
+ (when (and (pair? outer-form)
+ (not (let walker ((tree outer-form)) ; check even the enclosing env -- define in do body back ref'd in stepper for example
+ (or (eq? new-var tree)
+ (and (pair? tree)
+ (not (eq? n tree))
+ (not (eq? n-1 tree))
+ (not (eq? (car tree) 'quote))
+ (or (walker (car tree))
+ (walker (cdr tree))))))))
+ (let ((named (if (tree-memq new-var (cddr n-1)) (list new-var) ())))
+ (if (eq? (car n) (caadr n-1))
+ (lint-format "perhaps change ~A to a ~Alet: ~A" caller new-var (if (pair? named) "named " "")
+ (lists->string outer-form `(... (let , at named ,(map list (cdadr n-1) (cdr n)) ...))))
+ (let ((call (find-call new-var n)))
+ (when (and (pair? call)
+ (eqv? (length (cdadr n-1)) (length (cdr call))))
+ (let ((new-call `(let , at named ,(map list (cdadr n-1) (cdr call)) ,@(cddr n-1))))
+ (lint-format "perhaps embed ~A: ~A" caller new-var
+ (lists->string outer-form `(... ,(tree-subst new-call call n))))))))))))))
+ ;; needs to check outer let also -- and maybe complain? [outer = form: we're already closed?]
+ ;; bounds of closable context might be dependent on body length
+ ;; (let ((outer-form (cond ((var-member :let env) => var-initial-value) (else #f)))
+ ;; if used just once, move to that point in the expr+1? -- need to point it out somehow?
+
+ (when (and (> len 2)
+ (not (tree-memq 'curlet (list-ref body (- len 1)))))
+ (do ((q body (cdr q))
+ (k 0 (+ k 1)))
+ ((null? q))
+ (let ((expr (car q)))
+ (when (and (pair? expr)
+ (eq? (car expr) 'define)
+ (pair? (cdr expr))
+ (pair? (cddr expr))
+ (null? (cdddr expr)))
+ (let ((name (and (symbol? (cadr expr)) (cadr expr))))
+ (when name
+ (let ((last-ref k))
+ (do ((p (cdr q) (cdr p))
+ (i (+ k 1) (+ i 1)))
+ ((null? p)
+ (if (and (< k last-ref (+ k 2))
+ (pair? (list-ref body (+ k 1))))
+ (let ((end-dots (if (< last-ref (- len 1)) '(...) ()))
+ (letx (if (tree-member name (cddr expr)) 'letrec 'let))
+ (use-expr (list-ref body (+ k 1)))
+ (seen-earlier (or (var-member name env)
+ (do ((s body (cdr s)))
+ ((or (eq? s q)
+ (and (pair? (car s))
+ (tree-memq name (car s))))
+ (not (eq? s q)))))))
+ (unless seen-earlier
+ (cond ((not (eq? (car use-expr) 'define))
+ (let-temporarily ((target-line-length 120))
+ (lint-format "the scope of ~A could be reduced: ~A" caller name
+ (truncated-lists->string `(... ,expr ,use-expr , at end-dots)
+ `(... (,letx ((,name ,(caddr expr)))
+ ,use-expr)
+ , at end-dots)))))
+ ((eq? (cadr use-expr) name)
+ (lint-format "use set! to redefine ~A: ~A" caller name
+ (lists->string `(... ,use-expr , at end-dots)
+ `(... (set! ,name ,(caddr use-expr)) , at end-dots))))
+ ((pair? (cadr use-expr))
+ (if (symbol? (caadr use-expr))
+ (let-temporarily ((target-line-length 120))
+ (lint-format "perhaps move ~A into ~A's closure: ~A" caller name (caadr use-expr)
+ (truncated-lists->string `(... ,expr ,use-expr , at end-dots)
+ `(... (define ,(caadr use-expr)
+ (,letx ((,name ,(caddr expr)))
+ (lambda ,(cdadr use-expr)
+ ,@(cddr use-expr))))
+ , at end-dots))))))
+ ((and (symbol? (cadr use-expr))
+ (pair? (cddr use-expr)))
+ (let-temporarily ((target-line-length 120))
+ (if (and (pair? (caddr use-expr))
+ (eq? (caaddr use-expr) 'lambda))
+ (lint-format "perhaps move ~A into ~A's closure: ~A" caller name (cadr use-expr)
+ (truncated-lists->string `(... ,expr ,use-expr , at end-dots)
+ `(... (define ,(cadr use-expr)
+ (,letx ((,name ,(caddr expr)))
+ ,(caddr use-expr)))
+ , at end-dots)))
+ (lint-format "the scope of ~A could be reduced: ~A" caller name
+ (truncated-lists->string `(... ,expr ,use-expr , at end-dots)
+ `(... (define ,(cadr use-expr)
+ (,letx ((,name ,(caddr expr)))
+ ,(caddr use-expr)))
+ , at end-dots)))))))))
+ (when (and (> len 3)
+ (< k last-ref (+ k 3)) ; larger cases happen very rarely -- 3 or 4 altogether
+ (pair? (list-ref body (+ k 1)))
+ (pair? (list-ref body (+ k 2))))
+ (let ((end-dots (if (< last-ref (- len 1)) '(...) ()))
+ (letx (if (tree-member name (cddr expr)) 'letrec 'let))
+ (seen-earlier (or (var-member name env)
+ (do ((s body (cdr s)))
+ ((or (eq? s q)
+ (and (pair? (car s))
+ (tree-memq name (car s))))
+ (not (eq? s q)))))))
+ (unless seen-earlier
+ (let ((use-expr1 (list-ref body (+ k 1)))
+ (use-expr2 (list-ref body (+ k 2))))
+ (if (not (or (tree-set-member '(define lambda) use-expr1)
+ (tree-set-member '(define lambda) use-expr2)))
+ (lint-format "the scope of ~A could be reduced: ~A" caller name
+ (let-temporarily ((target-line-length 120))
+ (truncated-lists->string `(... ,expr ,use-expr1 ,use-expr2 , at end-dots)
+ `(... (,letx ((,name ,(caddr expr)))
+ ,use-expr1
+ ,use-expr2)
+ , at end-dots)))))))))))
+ (when (tree-memq name (car p))
+ (set! last-ref i))))))))))))
+
;; definer as last in body is rare outside let-syntax, and tricky -- only one clear optimizable case found
(lint-walk-open-body caller head body env))
+
(define (lint-walk-open-body caller head body env)
;; walk a body (a list of forms, the value of the last of which might be returned)
@@ -8350,13 +9639,40 @@
((not (pair? fs)))
(let ((f (car fs)))
- (when (and (pair? prev-f) ; (if A ...) (if A ...) -> (when A ...) or equivalents
- (pair? f)
- (eq? (car f) 'if)
- (eq? (car prev-f) 'if)
- (pair? (cdr f))
- (pair? (cdr prev-f)))
- ;; cond/case occasionally are repeated, but almost never in a way we can combine
+ (when (and (pair? f)
+ (eq? (car f) 'define)
+ (pair? (cdr f)))
+ (let ((vname (if (symbol? (cadr f))
+ (cadr f)
+ (and (pair? (cadr f))
+ (symbol? (caadr f))
+ (caadr f)))))
+ ;; if already in env, check shadowing request
+ (if (and *report-shadowed-variables*
+ (var-member vname env))
+ (lint-format "~A variable ~A in ~S shadows an earlier declaration" caller head vname f))
+#|
+ ;; define after executable statement in sequence -- make sure last form (which needs to exist) was not a define
+ (if (and (pair? prev-f)
+ (symbol? (car prev-f))
+ (not (string-position "def" (symbol->string (car prev-f)))))
+ (format *stderr* "~A:~% ~A in ~A~%~%" *current-file* vname (truncated-list->string body)))
+ ;; perhaps also check that (car prev-f) was a known procedure or non-defining syntax
+ ;; then warn (?) about back propogation, or maybe rewrite as in lint-walk-body??
+ ;; need to check backwards??
+ ;; could also check for other define-* forms here
+ ;; and could check for shadowing -- if already defined in this env suggest set!? -- it is setting not binding, I think, so maybe warn
+|#
+ ))
+
+
+ ;; generalized cases happen about a dozen times and there are only 2 cases where car f != car prev-f
+ (when (and (pair? prev-f) ; (if A ...) (if A ...) -> (when A ...) or equivalents
+ (pair? f)
+ (eq? (car f) (car prev-f))
+ (memq (car f) '(if when unless))
+ (pair? (cdr f))
+ (pair? (cdr prev-f)))
(define (tree-change-member set tree)
(and (pair? tree)
@@ -8366,45 +9682,55 @@
(tree-change-member set (car tree))
(tree-change-member set (cdr tree)))))
- (if (and (equal? (cadr f) (cadr prev-f))
- (not (side-effect? (cadr f) env))
- (not (tree-change-member (gather-symbols (cadr prev-f)) (cddr prev-f))))
- (lint-format "perhaps ~A" caller
- (lists->string `(... ,prev-f ,f ...)
- (if (and (null? (cdddr prev-f))
- (null? (cdddr f)))
- (if (and (pair? (cadr f))
- (eq? (caadr f) 'not))
- `(... (unless ,(cadadr f)
- ,@(unbegin (caddr prev-f))
- ,@(unbegin (caddr f))) ...)
- `(... (when ,(cadr f)
- ,@(unbegin (caddr prev-f))
- ,@(unbegin (caddr f))) ...))
- `(... (if ,(cadr f)
- (begin
- ,@(unbegin (caddr prev-f))
- ,@(unbegin (caddr f)))
- (begin
- ,@(if (pair? (cdddr prev-f)) (unbegin (cadddr prev-f)) ())
- ,@(if (pair? (cdddr f)) (unbegin (cadddr f)) ())))
- ...))))
- (if (and (pair? (cadr f)) ; (if A B C) (if (and D A) F) -> (if A (begin B (if D F)) C)
- (eq? (caadr f) 'and)
- (member (cadr prev-f) (cdadr f))
- (not (side-effect? (cadr f) env))
- (not (tree-change-member (gather-symbols (cadr prev-f)) (cddr prev-f))))
- (lint-format "perhaps ~A" caller
- (let ((new-test (remove (cadr prev-f) (cadr f))))
- (lists->string `(... ,prev-f ,f ...)
- `(... (if ,(cadr prev-f)
- (begin
- ,(caddr prev-f)
- (if ,(if (pair? (cddr new-test))
- new-test
- (cadr new-test))
- ,@(cddr f)))
- ,@(cdddr prev-f)) ...)))))))
+ (let ((test1 (cadr prev-f))
+ (test2 (cadr f)))
+ (if (and (equal? test1 test2)
+ (not (side-effect? test1 env))
+ (not (tree-change-member (gather-symbols test1) (cdr prev-f))))
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ `(... ,prev-f ,f ...)
+ (if (eq? (car f) 'if)
+ (if (and (null? (cdddr prev-f))
+ (null? (cdddr f)))
+ (if (and (pair? (cadr f))
+ (eq? (caadr f) 'not))
+ `(... (unless ,(cadadr f)
+ ,@(unbegin (caddr prev-f))
+ ,@(unbegin (caddr f))) ...)
+ `(... (when ,(cadr f)
+ ,@(unbegin (caddr prev-f))
+ ,@(unbegin (caddr f))) ...))
+ `(... (if ,(cadr f)
+ (begin
+ ,@(unbegin (caddr prev-f))
+ ,@(unbegin (caddr f)))
+ (begin
+ ,@(if (pair? (cdddr prev-f)) (unbegin (cadddr prev-f)) ())
+ ,@(if (pair? (cdddr f)) (unbegin (cadddr f)) ())))
+ ...))
+ `(,(car f) ,(cadr f)
+ ,@(cddr prev-f)
+ ,@(cddr f)))))
+
+ (if (and (eq? (car f) 'if)
+ (pair? (cadr f)) ; (if A B C) (if (and D A) F) -> (if A (begin B (if D F)) C)
+ (eq? (caadr f) 'and)
+ (member (cadr prev-f) (cdadr f))
+ (not (side-effect? (cadr f) env))
+ (not (tree-change-member (gather-symbols (cadr prev-f)) (cddr prev-f))))
+ (lint-format "perhaps ~A" caller
+ (let ((new-test (remove (cadr prev-f) (cadr f))))
+ (lists->string `(... ,prev-f ,f ...)
+ `(... (if ,(cadr prev-f)
+ (begin
+ ,(caddr prev-f)
+ (if ,(if (pair? (cddr new-test))
+ new-test
+ (cadr new-test))
+ ,@(cddr f)))
+ ,@(cdddr prev-f)) ...))))))))
+
;; --------
;; check for repeated calls, but only one arg currently can change (more args = confusing separation in code)
(let ((feq (and (pair? prev-f)
@@ -8437,7 +9763,7 @@
(if (zero? repeat-arg) ; simple case -- all exprs are identical
(let ((step 'i))
(if (tree-member step prev-f)
- (set! step (find-unique-name prev-f #f)))
+ (set! step (find-unique-name prev-f)))
(lint-format "perhaps ~A... ->~%~NC(do ((~A 0 (+ ~A 1))) ((= ~A ~D)) ~A)" caller
(truncated-list->string prev-f)
pp-left-margin #\space
@@ -8448,12 +9774,12 @@
(constants? #t)
(func-name (car prev-f))
(new-arg (if (tree-member 'arg prev-f)
- (find-unique-name prev-f #f)
+ (find-unique-name prev-f)
'arg)))
(do ((p start-repeats (cdr p)))
((eq? p fs-end))
(set! args (cons (list-ref (car p) repeat-arg) args))
- (set! constants? (and constants? (code-constant? (car args)))))
+ (if constants? (set! constants? (code-constant? (car args)))))
(let ((func (if (and (= repeat-arg 1)
(null? (cddar start-repeats)))
@@ -8495,7 +9821,8 @@
(if (eq? (car f) 'begin)
(lint-format "redundant begin: ~A" caller (truncated-list->string f))))
(begin
- (set-ref f caller f env)
+ (if (symbol? f)
+ (set-ref f caller f env))
(set! f-len 0)))
(when (and (= f-len prev-len 3)
@@ -8520,6 +9847,18 @@
prev-f f
`(set! ,(cadr f) (cons ,(cadr arg2) (cons ,@(cdr arg1))))))
+ ((and (pair? arg1) ; (set! x (append x y)) (set! x (append x z)) -> (set! x (append x y z))
+ (pair? arg2)
+ (eq? (car arg1) 'append)
+ (eq? (car arg2) 'append)
+ (eq? (cadr f) (cadr arg1))
+ (eq? (cadr f) (cadr arg2))
+ (not (tree-memq (cadr f) (cddr arg1)))
+ (not (tree-memq (cadr f) (cddr arg2))))
+ (lint-format "perhaps ~A ~A -> ~A" caller
+ prev-f f
+ `(set! ,(cadr f) (append ,(cadr f) ,@(cddr arg1) ,@(cddr arg2)))))
+
((and (= (tree-count1 (cadr f) arg2 0) 1) ; (set! x y) (set! x (+ x 1)) -> (set! x (+ y 1))
(or (not (pair? arg1))
(< (tree-leaves arg1) 5)))
@@ -8548,7 +9887,7 @@
(eq? (var-initial-value v) :call/cc))))))
(cdr f)))
(if (= ctr (- len 2))
- (lint-format "~A make this pointless: ~A" caller
+ (lint-format "~A makes this pointless: ~A" caller
(truncated-list->string f)
(truncated-list->string (cadr fs)))
(lint-format "~A makes the rest of the body unreachable: ~A" caller
@@ -8619,8 +9958,27 @@
(and (not (eq? (car prev-f) 'set!))
(pair? (cadr prev-f)) ; (begin ... (define (x...)...) x)
(eq? f (caadr prev-f)))))
- (lint-format "~A returns the new value, so this could be omitted: ~A" caller
- (car prev-f) (truncated-list->string f)))))))
+ (cond ((not (memq (car prev-f) '(define define*)))
+ (lint-format "~A returns the new value, so this could be omitted: ~A" caller
+ (car prev-f) (truncated-list->string f)))
+
+ ((symbol? (cadr prev-f))
+ (lint-format "perhaps omit ~A and return ~A" caller
+ (cadr prev-f)
+ (caddr prev-f)))
+
+ ((= (tree-count2 f body 0) 2)
+ (lint-format "perhaps omit ~A, and change ~A" caller
+ f
+ (lists->string `(,(car prev-f) ,(cadr prev-f) ...)
+ `(,(if (eq? (car prev-f) 'define) 'lambda 'lambda*)
+ ,(cdadr prev-f)
+ ...))))
+
+ (else (lint-format "~A returns the new value, so this could be omitted: ~A" caller
+ (car prev-f) f))))))))
+ ; possibly still not right if letrec?
+
;; needs f fs prev-f dpy-f dpy-start ctr len
;; trap lint-format
@@ -8630,7 +9988,7 @@
(not dpy-start))
(set! dpy-f fs)
(set! dpy-start ctr))
- (when (and dpy-start
+ (when (and (integer? dpy-start)
(> (- ctr dpy-start) (if dpy-case 1 2))
(or (= ctr (- len 1))
(not dpy-case)))
@@ -8700,6 +10058,60 @@
env)
+ (define (check-sequence-constant function-name last)
+ (let ((seq (if (not (pair? last))
+ last
+ (and (eq? (car last) 'quote)
+ (pair? (cdr last)) ; (quote . 1)
+ (cadr last)))))
+ (if (and (sequence? seq)
+ (> (length seq) 0))
+ (begin
+ (lint-format "returns ~A constant: ~A~S" function-name
+ (if (pair? seq)
+ (values "a list" "'" seq)
+ (values (prettify-checker-unq (->lint-type last)) "" seq)))
+ (throw 'sequence-constant-done)) ; just report one constant -- the full list is annoying
+ (when (pair? last)
+ (case (car last)
+
+ ((begin let let* letrec letrec* when unless with-baffle with-let)
+ (when (pair? (cdr last))
+ (let ((len (length last)))
+ (when (positive? len)
+ (check-sequence-constant function-name (list-ref last (- len 1)))))))
+
+ ((if)
+ (when (and (pair? (cdr last))
+ (pair? (cddr last)))
+ (check-sequence-constant function-name (caddr last))
+ (if (pair? (cdddr last))
+ (check-sequence-constant function-name (cadddr last)))))
+
+ ((cond)
+ (for-each (lambda (c)
+ (if (and (pair? c)
+ (pair? (cdr c)))
+ (check-sequence-constant function-name (list-ref (cdr c) (- (length (cdr c)) 1)))))
+ (cdr last)))
+
+ ((case)
+ (when (and (pair? (cdr last))
+ (pair? (cddr last)))
+ (for-each (lambda (c)
+ (if (and (pair? c)
+ (pair? (cdr c)))
+ (check-sequence-constant function-name (list-ref (cdr c) (- (length (cdr c)) 1)))))
+ (cddr last))))
+
+ ((do)
+ (if (and (pair? (cdr last))
+ (pair? (cddr last))
+ (pair? (caddr last))
+ (pair? (cdaddr last)))
+ (check-sequence-constant function-name (list-ref (cdaddr last) (- (length (cdaddr last)) 1))))))))))
+
+
(define (lint-walk-function-body definer function-name args body env)
;; walk function body, with possible doc string at the start
(when (and (pair? body)
@@ -8716,6 +10128,13 @@
,args
,@(cdr body)))))))
(set! body (cdr body))) ; ignore old-style doc-string
+ ;; (set! arg ...) never happens as last in body
+
+ (catch 'sequence-constant-done
+ (lambda ()
+ (check-sequence-constant function-name (list-ref body (- (length body) 1))))
+ (lambda args #f))
+
(lint-walk-body function-name definer body env))
(define (lint-walk-function definer function-name args body form env)
@@ -8778,7 +10197,7 @@
(equal? (cddar bval) (proper-list args)))))
(lint-format "~A could be (define ~A ~A)" function-name function-name function-name (cadar bval)))
- ((and (memq (caar bval) '(car cdr caar cadr cddr cdar caaar caadr caddr cdddr cdaar cddar cadar cdadr cadddr cddddr))
+ ((and (memq (caar bval) combinable-cxrs)
(pair? (cadar bval)))
((lambda* (cr arg)
(and cr
@@ -8786,7 +10205,7 @@
(pair? args)
(null? (cdr args))
(eq? (car args) arg)
- (let ((f (string->symbol (string-append "c" cr "r"))))
+ (let ((f (symbol "c" cr "r")))
(if (eq? f function-name)
(lint-format "this redefinition of ~A is pointless (use (with-let (unlet)...) or #_~A)" definer function-name function-name)
(lint-format "~A could be (define ~A ~A)" function-name function-name function-name f)))))
@@ -8820,9 +10239,7 @@
:env env
:arglist (if (memq definer '(lambda lambda*))
(cadr form)
- (if (memq definer '(defmacro defmacro*))
- (caddr form)
- (cdadr form)))))))
+ ((if (memq definer '(defmacro defmacro*)) caddr cdadr) form))))))
(when fvar
(let ((fvar-let (cdr fvar)))
(set! (fvar-let 'decl)
@@ -8886,7 +10303,7 @@
(make-var :name arg :definer 'parameter))
(if (not (and (pair? arg)
(= (length arg) 2)
- (memq definer '(define* lambda* defmacro* define-macro* define-bacro* definstrument))))
+ (memq definer '(define* lambda* defmacro* define-macro* define-bacro* definstrument define*-public))))
(begin
(lint-format "strange parameter for ~A: ~S" function-name definer arg)
(values))
@@ -8896,7 +10313,10 @@
(make-var :name (car arg) :definer 'parameter)))))
(proper-list args)))))
- (let* ((cur-env (append args-as-vars (if fvar (cons fvar env) env)))
+ (let* ((cur-env (cons (make-var :name :let
+ :initial-value form
+ :definer definer)
+ (append args-as-vars (if fvar (cons fvar env) env))))
(e (lint-walk-function-body definer function-name args body cur-env))
(nvars (and (not (eq? e cur-env))
(env-difference function-name e cur-env ()))))
@@ -9015,7 +10435,7 @@
`(,(map (lambda (p)
(case (car p)
((eq? eqv? = equal? char=?)
- (unquoted (if (equal? eqv-select (cadr p)) (caddr p) (cadr p))))
+ (unquoted ((if (equal? eqv-select (cadr p)) caddr cadr) p)))
((memq memv member) (apply values (caddr p)))
((not) #f)
((null?) ())
@@ -9087,9 +10507,16 @@
(else #f))))
(define (find-constant-exprs caller vars body)
- (if (tree-set-member '(call/cc call-with-current-continuation lambda lambda* define define*
- define-macro define-macro* define-bacro define-bacro* define-constant define-expansion)
- body)
+ (if (or (tree-set-member '(call/cc call-with-current-continuation lambda lambda* define define*
+ define-macro define-macro* define-bacro define-bacro* define-constant define-expansion)
+ body)
+ (let set-walk ((tree body)) ; generalized set! causes confusion
+ (and (pair? tree)
+ (or (and (eq? (car tree) 'set!)
+ (pair? (cdr tree))
+ (pair? (cadr tree)))
+ (set-walk (car tree))
+ (set-walk (cdr tree))))))
()
(let* ((vs (out-vars caller vars body))
(refs (remove-if (lambda (v)
@@ -9166,54 +10593,6 @@
constant-exprs)))
constant-exprs)))
- (define (find-let-constant-exprs caller form vars body)
- (let ((zv (map (lambda (v)
- (if (and (zero? (var-set v))
- (not (tree-unquoted-member (var-name v) (var-initial-value v))))
- v
- (values)))
- vars)))
- (when (pair? zv)
- (let ((constant-exprs (find-constant-exprs 'let (map (lambda (v)
- (if (positive? (var-set v))
- (var-name v)
- (values)))
- vars)
- body)))
- (when (pair? constant-exprs)
- (let ((vals (map (lambda (v)
- (cons (var-initial-value v) (var-name v)))
- zv)))
- (for-each (lambda (expr)
- (cond ((or (assoc expr vals)
- (and (pair? expr)
- (hash-table-ref reversibles (car expr))
- (= 3 (length expr))
- (assoc (list (hash-table-ref reversibles (car expr)) (caddr expr) (cadr expr)) vals)))
- => (lambda (ev)
- (lint-format* caller
- (string-append (object->string (car ev)) " is " (object->string (cdr ev)) " in ")
- (truncated-list->string form))))))
- constant-exprs)))))))
-
- (define (find-call sym body)
- (call-with-exit
- (lambda (return)
- (let tree-call ((tree body))
- (if (and (pair? tree)
- (not (eq? (car tree) 'quote)))
- (begin
- (if (eq? (car tree) sym)
- (return tree))
- (if (memq (car tree) '(let let* letrec letrec* do lambda lambda* define))
- (return #f)) ; possible shadowing -- not worth the infinite effort to corroborate
- (if (pair? (car tree))
- (tree-call (car tree)))
- (if (pair? (cdr tree))
- (do ((p (cdr tree) (cdr p)))
- ((not (pair? p)) #f)
- (tree-call (car p))))))))))
-
(define (partition-form start len)
(let ((ps (make-vector len))
(qs (make-vector len)))
@@ -9254,4013 +10633,4632 @@
(values header-len trailer-len result-min-len))))
(define (one-call-and-dots body) ; body is unchanged here, so it's not interesting
- (if (null? (cdr body))
- body
- (list (car body) '...)))
+ (if (< (tree-leaves body) 30)
+ (if (null? (cdr body))
+ body
+ (list (car body) '...))
+ (if (pair? (car body))
+ (list (list (caar body) '...))
+ (list (car body) '...))))
(define (replace-redundant-named-let caller form outer-name outer-args inner)
- (if (proper-list? outer-args) ; can be null
- (let ((inner-name (cadr inner))
- (inner-args (caddr inner))
- (inner-body (cdddr inner)))
- (do ((p outer-args (cdr p))
- (a inner-args (cdr a)))
- ((or (null? p)
- (not (pair? a))
- (not (pair? (car a)))
- (and (not (eq? (car p) (caar a)))
- (tree-memq (car p) inner-body)))
- ;; args can be reversed, but rarely match as symbols
- (if (and (null? p)
+ (when (proper-list? outer-args) ; can be null
+ (let ((inner-name (cadr inner))
+ (inner-args (caddr inner))
+ (inner-body (cdddr inner)))
+ (do ((p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((or (null? p)
+ (not (pair? a))
+ (not (pair? (car a)))
+ (and (not (eq? (car p) (caar a)))
+ (tree-memq (car p) inner-body)))
+ ;; args can be reversed, but rarely match as symbols
+ (when (and (null? p)
(or (null? a)
(and (null? (cdr a))
(code-constant? (cadar a)))))
- (let* ((args-match (do ((p outer-args (cdr p))
- (a inner-args (cdr a)))
- ((or (null? p)
- (not (eq? (car p) (caar a)))
- (not (eq? (caar a) (cadar a))))
- (null? p))))
- (args-aligned (and (not args-match)
- (do ((p outer-args (cdr p))
- (a inner-args (cdr a)))
- ((or (null? p)
- (not (eq? (car p) (cadar a))))
- (null? p))))))
- (if (or args-match args-aligned)
- (let ((definer (if (null? a) 'define 'define*))
- (extras (if (and (pair? a)
- (quoted-null? (cadar a)))
- (list (list (caar a) ()))
- a)))
- (lint-format "~A ~A" caller
- (if (null? a) "perhaps" "a toss-up -- perhaps")
- (lists->string form
- `(,definer (,outer-name
- ,@(if args-match
- outer-args
- (do ((result ())
- (p outer-args (cdr p))
- (a inner-args (cdr a)))
- ((null? p)
- (reverse result))
- (set! result (cons (caar a) result))))
- , at extras)
- ,@(tree-subst outer-name inner-name inner-body)))))))))))))
-
- (define lint-walk
- (let ((deprecated-ops '((global-environment . rootlet)
- (current-environment . curlet)
- (make-procedure-with-setter . dilambda)
- (procedure-with-setter? . dilambda?)
- (make-random-state . random-state)
- ;;(make-rectangular . complex)
- (data-format . sample-type)
- (mus-sound-frames . mus-sound-framples)
- (mus-sound-data-format . mus-sound-sample-type)
- (mus-data-format-name . mus-sample-type-name)
- (mus-data-format->string . mus-sample-type->string)))
-
- (numeric-ops (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h op) #t))
- '(+ * - /
- sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh
- log exp expt sqrt make-polar complex
- imag-part real-part abs magnitude angle max min exact->inexact
- modulo remainder quotient lcm gcd
- rationalize inexact->exact random
- logior lognot logxor logand numerator denominator
- floor round truncate ceiling ash))
- h))
-
- (binders (let ((h (make-hash-table)))
- (for-each
- (lambda (op)
- (set! (h op) #t))
- '(let let* letrec letrec* do
- lambda lambda* define define*
- call/cc call-with-current-continuation
- define-macro define-macro* define-bacro define-bacro* define-constant define-expansion
- load eval eval-string require))
- h))
-
- (lint-let-reduction-factor 3) ; maybe make this a global switch -- the higher this number, the fewer let-reduction suggestions
- (selector-types '(#t symbol? char? boolean? integer? rational? real? complex? number? null? eof-object?)))
-
- (lambda (caller form env)
-
- ;; walk a form, here curlet can change
- ;; (format *stderr* "lint-walk ~A~%" form)
-
- (if (symbol? form)
- (begin
- (if (memq form '(+i -i))
- (format outport "~NC~A is not a number in s7~%" lint-left-margin #\space form))
- (set-ref form caller #f env)) ; returns env
- (if (not (pair? form))
- (begin
- (if (vector? form)
- (let ((happy #t))
+ (let* ((args-match (do ((p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((or (null? p)
+ (not (eq? (car p) (caar a)))
+ (not (eq? (caar a) (cadar a))))
+ (null? p))))
+ (args-aligned (and (not args-match)
+ (do ((p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((or (null? p)
+ (not (eq? (car p) (cadar a))))
+ (null? p))))))
+ (when (or args-match args-aligned)
+ (let ((definer (if (null? a) 'define 'define*))
+ (extras (if (and (pair? a)
+ (quoted-null? (cadar a)))
+ (list (list (caar a) ()))
+ a)))
+ (lint-format "~A ~A" caller
+ (if (null? a) "perhaps" "a toss-up -- perhaps")
+ (lists->string form
+ `(,definer (,outer-name
+ ,@(if args-match
+ outer-args
+ (do ((result ())
+ (p outer-args (cdr p))
+ (a inner-args (cdr a)))
+ ((null? p)
+ (reverse result))
+ (set! result (cons (caar a) result))))
+ , at extras)
+ ,@(tree-subst outer-name inner-name inner-body)))))))))))))
+
+ (define (set!? form env)
+ (and *report-any-!-as-setter* ; (inc! x) when inc! is unknown, assume it sets x
+ (symbol? (car form))
+ (pair? (cdr form))
+ (or (symbol? (cadr form))
+ (and (pair? (cddr form))
+ (symbol? (caddr form))))
+ (not (var-member (car form) env))
+ (not (hash-table-ref built-in-functions (car form)))
+ (let ((str (symbol->string (car form))))
+ (char=? (string-ref str (- (length str) 1)) #\!))))
+
+ (define (set-target name form env)
+ (and (pair? form)
+ (or (and (pair? (cdr form))
+ (or (eq? (cadr form) name) ; (pop! x)
+ (and (pair? (cddr form)) ; (push! y x)
+ (eq? (caddr form) name)))
+ (or (eq? (car form) 'set!) ; (set! x y)
+ (set!? form env)))
+ (set-target name (car form) env)
+ (set-target name (cdr form) env))))
+
+
+ (define (check-definee caller sym form env)
+ (let ((val (cddr form)))
+ (cond ((keyword? sym) ; (define :x 1)
+ (lint-format "keywords are constants ~A" caller sym))
+
+ ((and (eq? sym 'pi) ; (define pi (atan 0 -1))
+ (member (car val) '((atan 0 -1)
+ (acos -1)
+ (* 2 (acos 0))
+ (* 4 (atan 1))
+ (* 4 (atan 1 1)))))
+ (lint-format "~A is one of its many names, but pi is a predefined constant in s7" caller (car val)))
+
+ ((constant? sym) ; (define most-positive-fixnum 432)
+ (lint-format "~A is a constant in s7: ~A" caller sym form))
+
+ ((eq? sym 'quote)
+ (lint-format "either a stray quote, or a real bad idea: ~A" caller (truncated-list->string form)))
+
+ ((pair? sym)
+ (check-definee caller (car sym) form env))
+
+ ((let ((v (var-member sym env)))
+ (and (var? v)
+ (eq? (var-definer v) 'define-constant)
+ (not (equal? (caddr form) (var-initial-value v)))))
+ (let ((v (var-member sym env)))
+ (lint-format "~A in ~A is already a constant, defined ~A~A" caller sym
+ (truncated-list->string form)
+ (if (and (pair? (var-initial-value v))
+ (positive? (pair-line-number (var-initial-value v))))
+ (format #f "(line ~D): " (pair-line-number (var-initial-value v)))
+ "")
+ (truncated-list->string (var-initial-value v))))))))
+
+ (define binders (let ((h (make-hash-table)))
(for-each
- (lambda (x)
- (when (and (pair? x)
- (eq? (car x) 'unquote))
- (lint-walk caller (cadr x) env) ; register refs
- (set! happy #f)))
- form)
- (if (not happy) ; these are used exactly 4 times (in a test suite!) in 2 million lines of open source scheme code
- (lint-format "quasiquoted vectors are not supported: ~A" caller form))))
- env)
- (let ((head (car form)))
-
- (set! line-number (pair-line-number form))
-
- (when *report-function-stuff*
- (function-match caller form env))
-
- (case head
-
- ;; ---------------- define ----------------
- ((define define* define-constant
- define-macro define-macro* define-bacro define-bacro* define-expansion
- definstrument defanimal define-envelope ; for clm
- define-public define-inlinable define-integrable define^) ; these give more informative names in Guile and scmutils (MIT-scheme)
+ (lambda (op)
+ (set! (h op) #t))
+ '(let let* letrec letrec* do
+ lambda lambda* define define*
+ call/cc call-with-current-continuation
+ define-macro define-macro* define-bacro define-bacro* define-constant define-expansion
+ load eval eval-string require))
+ h))
+
+ (define lint-let-reduction-factor 3) ; maybe make this a global switch -- the higher this number, the fewer let-reduction suggestions
+
+ (define walker-functions
+ (let ((h (make-hash-table)))
- (if (< (length form) 2)
- (begin
- (lint-format "~S makes no sense" caller form)
- env)
- (let ((sym (cadr form))
- (val (cddr form)))
- (if (symbol? sym)
- (begin
+ ;; ---------------- define ----------------
+ (let ()
+ (define (define-walker caller form env)
+ (if (< (length form) 2)
+ (begin
+ (lint-format "~S makes no sense" caller form)
+ env)
+ (let ((sym (cadr form))
+ (val (cddr form))
+ (head (car form)))
+ (if (symbol? sym)
+ (begin
+ (check-definee caller sym form env)
+
+ (if (memq head '(define define-constant define-envelope
+ define-public define*-public defmacro-public define-inlinable
+ define-integrable define^))
+ (let ((len (length form)))
+ (if (not (= len 3))
+ (lint-format "~A has ~A value~A?"
+ caller (truncated-list->string form)
+ (if (< len 3)
+ (values "no" "")
+ (values "too many" "s")))))
+ (lint-format "~A is messed up" caller (truncated-list->string form)))
+
+ (if (not (pair? val))
+ env
+ (begin
+ (if (and (null? (cdr val))
+ (equal? sym (car val)))
+ (lint-format "this ~A is either not needed, or is an error: ~A" caller head (truncated-list->string form)))
+
+ (if (not (pair? (car val)))
+ (begin
+ (if (not (memq caller '(module cond-expand)))
+ (cond ((hash-table-ref other-identifiers sym)
+ => (lambda (p)
+ (lint-format "~A is used before it is defined: ~A" caller sym form)))))
+ (cons (make-var :name sym :initial-value (car val) :definer head) env))
+
+ (let ((e (lint-walk (if (and (pair? (car val))
+ (eq? (caar val) 'letrec))
+ 'define sym)
+ (car val) env)))
+ (if (or (not (pair? e))
+ (eq? e env)
+ (not (eq? (var-name (car e)) :lambda))) ; (define x (lambda ...))
+ (cons (make-var :name sym :initial-value (car val) :definer head) env)
+ (begin
+ (set! (var-name (car e)) sym)
+
+ (let ((val (caddr form)))
+ (when (and (eq? (car val) 'lambda) ; (define sym (lambda args (let name...))), let here happens rarely
+ (proper-list? (cadr val))
+ (pair? (caddr val))
+ (null? (cdddr val))
+ (eq? (caaddr val) 'let)
+ (symbol? (cadr (caddr val))))
+ (replace-redundant-named-let caller form sym (cadr val) (caddr val))))
+
+ ;; (define x (letrec ((y (lambda...))) (lambda (...) (y...)))) -> (define (x...)...)
+ (let* ((let-form (caddr form))
+ (var (and (pair? (cadr let-form))
+ (null? (cdadr let-form)) ; just one var in let/rec
+ (caadr let-form))))
+ ;; let-form here can be (lambda...) or (let|letrec ... lambda)
+ (when (and (pair? var)
+ (symbol? (car var))
+ (pair? (cddr let-form))
+ (pair? (caddr let-form))
+ (null? (cdddr let-form)) ; just one form in the let/rec
+ (pair? (cdr var))
+ (pair? (cadr var))
+ (pair? (cdadr var))
+ (eq? (caadr var) 'lambda) ; var is lambda
+ (proper-list? (cadadr var))) ; it has no rest arg
+ (let ((body (caddr let-form)))
+ (when (and (eq? (car body) 'lambda) ; let/rec body is lambda calling var
+ (proper-list? (cadr body)) ; rest args are a headache
+ (pair? (caddr body))) ; (lambda (...) (...) where car is letrec func name
+ (if (eq? (caaddr body) (car var))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(define (,sym ,@(cadr body))
+ (let ,(car var)
+ ,(map list (cadadr var) (cdaddr body))
+ ,@(cddadr var)))))
+ (let ((call (find-call (car var) (caddr body))))
+ (when (and (pair? call) ; inner lambda body is (...some-expr...(sym...) ...)
+ (= (tree-count1 (car var) (caddr body) 0) 1))
+ (let ((new-call `(let ,(car var)
+ ,(map list (cadadr var) (cdr call))
+ ,@(cddadr var))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(define (,sym ,@(cadr body))
+ ,(tree-subst new-call call
+ (caddr body)))))))))))))
+ (when (and *report-function-stuff*
+ (pair? (caddr (var-initial-value (car e)))))
+ (hash-table-set! equable-closures (caaddr (var-initial-value (car e)))
+ (cons (car e) (or (hash-table-ref equable-closures (caaddr (var-initial-value (car e)))) ()))))
+ e))))))) ; symbol? sym
+
+ ;; not (symbol? sym)
+ (if (and (pair? sym) ; cadr form
+ (pair? val) ; cddr form
+ (not (pair? (car sym)))) ; pair would indicate a curried func or something equally stupid
+ (let ((outer-args (cdr sym))
+ (outer-name (car sym)))
+
+ (when *report-forward-functions*
+ ;; need to ignore macro usages here -- this happens ca 20000 times!
+ (cond ((hash-table-ref other-identifiers (car sym))
+ => (lambda (p)
+ (lint-format "~A is used before it is defined" caller (car sym))))))
+
+ (check-definee caller (car sym) form env)
+
+ (when (and (pair? (car val))
+ (eq? (caar val) 'let)
+ (pair? (cadar val)))
+ (let ((inner-vars (cadar val)))
+ (do ((p outer-args (cdr p)))
+ ((not (pair? p)))
+ (cond ((assq (car p) inner-vars) =>
+ (lambda (v)
+ (if (eq? (cadr v) (car p))
+ (lint-format "in ~A this let binding is pointless: ~A" caller
+ (truncated-list->string form)
+ v))))))))
+
+ ;; define + redundant named-let -- sometimes rewrites to define*
+ (when (and (pair? (car val))
+ (eq? (caar val) 'let)
+ (symbol? (cadar val))
+ (null? (cdr val)))
+ (replace-redundant-named-let caller form outer-name outer-args (car val)))
+
+ ;; perhaps this block should be on a *report-* switch --
+ ;; it translates some internal defines into named lets
+ ;; (or just normal lets, etc)
+ ;; this is not redundant given the walk-body translations because here
+ ;; we have the outer parameters and can check those against the inner ones
+ ;; leading (sometimes) to much nicer rewrites.
+ (when (and (pair? (car val))
+ (eq? (caar val) 'define) ; define* does not happen here
+ (pair? (cdr val))
+ (pair? (cadar val))) ; inner define (name ...)
+ (let ((inner-name (caadar val))
+ (inner-args (cdadar val))
+ (inner-body (cddar val))
+ (outer-body (cdddr form)))
+ (when (and (symbol? inner-name)
+ (proper-list? inner-args)
+ (pair? (car outer-body))
+ (= (tree-count1 inner-name outer-body 0) 1))
+ (let ((call (find-call inner-name outer-body)))
+ (when (pair? call)
+ (set! last-rewritten-internal-define (car val))
+ (let ((new-call (if (tree-memq inner-name inner-body)
+ (if (and (null? inner-args)
+ (null? outer-args))
+ (if (null? (cdr inner-body))
+ (car (tree-subst outer-name inner-name inner-body))
+ `(begin ,@(tree-subst outer-name inner-name inner-body)))
+ `(let ,inner-name
+ ,(if (null? inner-args) () (map list inner-args (cdr call)))
+ , at inner-body))
+ (if (or (null? inner-args)
+ (and (equal? inner-args outer-args)
+ (equal? inner-args (cdr call))))
+ (if (null? (cdr inner-body))
+ (car (tree-subst outer-name inner-name inner-body))
+ `(begin ,@(tree-subst outer-name inner-name inner-body)))
+ `(let ,(map list inner-args (cdr call))
+ , at inner-body)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,head ,sym
+ ,@(let ((p (tree-subst new-call call outer-body)))
+ (if (and (pair? p)
+ (pair? (car p))
+ (eq? (caar p) 'begin))
+ (cdar p)
+ p)))))))))))
+ (when (pair? outer-args)
+ (if (repeated-member? (proper-list outer-args) env)
+ (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string sym)))
+
+ (cond ((memq head '(define* define-macro* define-bacro* define*-public))
+ (check-star-parameters outer-name outer-args env))
+ ((list-any? keyword? outer-args)
+ (lint-format "~A parameter can't be a keyword: ~A" caller outer-name sym))
+ ((memq 'pi outer-args)
+ (lint-format "~A parameter can't be a constant: ~A" caller outer-name sym)))
+
+ ;; look for built-in names used as parameter names and used as functions internally(!)
+ ;; this requires a tree walker to ignore (for example) (let loop ((string string))...)
+ (for-each (lambda (p)
+ (let ((par (if (pair? p) (car p) p)))
+ (when (or (hash-table-ref built-in-functions par)
+ (hash-table-ref syntaces par))
+ (let ((call (call-with-exit
+ (lambda (return)
+ (let loop ((tree (cddr form)))
+ (if (pair? tree)
+ (if (eq? (car tree) par)
+ (return tree)
+ (case (car tree)
+ ((quote) #f)
+ ((let let*)
+ (if (pair? (cdr tree))
+ (if (symbol? (cadr tree))
+ (if (not (tree-memq par (caddr tree)))
+ (loop (cdddr tree)))
+ (if (not (tree-memq par (cadr tree)))
+ (loop (cddr tree))))))
+ ((letrec letrec*)
+ (if (and (pair? (cdr tree))
+ (not (tree-memq par (cadr tree))))
+ (loop (cddr tree))))
+ ((do)
+ (if (and (pair? (cdr tree))
+ (pair? (cddr tree))
+ (not (tree-memq par (cadr tree))))
+ (loop (cdddr tree))))
+ (else
+ (if (pair? (cdr tree))
+ (for-each loop (cdr tree)))
+ (if (pair? (car tree))
+ (loop (car tree))))))))))))
+ (if (and (pair? call)
+ (pair? (cdr call))
+ (not (eq? par (cadr call))))
+ (lint-format* caller
+ (string-append (object->string outer-name) "'s parameter " (symbol->string par))
+ (string-append " is called " (truncated-list->string call))
+ ": find a less confusing parameter name!"))))))
+ outer-args))
+
+ (when (and (eq? head 'define-macro)
+ (pair? val)
+ (null? (cdr val)))
+ (let ((body (car val)))
+ (if (and (null? outer-args) ; look for C macros translated as define-macro! -- this happens a lot sad to say
+ (or (not (symbol? body))
+ (keyword? body))
+ (or (not (pair? body))
+ (and (eq? (car body) 'quote)
+ (not (symbol? (cadr body)))
+ (or (not (pair? (cadr body)))
+ (eq? (caadr body) 'quote)))
+ (not (or (memq (car body) '(quote quasiquote list cons append))
+ (tree-set-member '(#_{list} #_{apply_values} #_{append}) body)))))
+ (lint-format "perhaps ~A or ~A" caller
+ (lists->string form `(define ,outer-name ,(unquoted (car val))))
+ (truncated-list->string `(define (,outer-name) ,(unquoted (car val))))))
+ (when (pair? body)
+ (case (car body)
+ ((#_{list})
+
+ (when (and (quoted-symbol? (cadr body))
+ (proper-list? outer-args))
+#|
+ (catch #t
+ (lambda ()
+ (if (catch #t
+ (lambda ()
+ (let walk ((p body))
+ (if (pair? p)
+ (or (and (eq? (car p) 'quote)
+ (not (hash-table-ref syntaces (cadr p))))
+ (and (walk (car p))
+ (walk (cdr p))))
+ (or (and (procedure? p)
+ (not (memq p '(#_{apply_values} #_{append}))))
+ (and (symbol? p)
+ (or (memq p outer-args)
+ (hash-table-ref no-side-effect-functions p))
+ (not (hash-table-ref syntaces p)))
+ (code-constant? p)))))
+ (lambda args #f))
+ (let* ((m (eval form))
+ (mx (apply macroexpand `((,outer-name , at outer-args)))))
+ (format *stderr* "~A -> ~A~%" form `(define (,outer-name , at outer-args) ,mx)))))
+ (lambda args #f))
+|#
- (cond ((keyword? sym) ; (define :x 1)
- (lint-format "keywords are constants ~A" caller sym))
-
- ((and (eq? sym 'pi) ; (define pi (atan 0 -1))
- (member (car val) '((atan 0 -1)
- (acos -1)
- (* 2 (acos 0))
- (* 4 (atan 1))
- (* 4 (atan 1 1)))))
- (lint-format "~A is one of its many names, but pi a predefined constant in s7" caller (car val)))
-
- ((constant? sym) ; (define most-positive-fixnum 432)
- (lint-format "~A is a constant in s7: ~A" caller sym form))
-
- ((let ((v (var-member sym env)))
- (and (var? v)
- (eq? (var-definer v) 'define-constant)
- (not (equal? (caddr form) (var-initial-value v)))))
- (let ((v (var-member sym env)))
- (lint-format "~A in ~A is already a constant, defined ~A~A" caller sym
- (truncated-list->string form)
- (if (and (pair? (var-initial-value v))
- (positive? (pair-line-number (var-initial-value v))))
- (format #f "(line ~D): " (pair-line-number (var-initial-value v)))
- "")
- (truncated-list->string (var-initial-value v))))))
-
- (if (memq head '(define define-constant define-envelope
- define-public define-inlinable define-integrable define^))
- (let ((len (length form)))
- (if (not (= len 3))
- (lint-format "~A has ~A value~A?"
- caller (truncated-list->string form)
- (if (< len 3)
- (values "no" "")
- (values "too many" "s")))))
- (lint-format "~A is messed up" caller (truncated-list->string form)))
-
- ;; can we see simple macros that should be functions? (any macro without ,@)
- ;; yes, but it almost never happens -- (lambda (x) ({list} 'car x))
- ;; from (define-macro (cr x) `(car ,x)) -> (define cr car)
-
- (if (and (pair? val)
- (null? (cdr val))
- (equal? sym (car val)))
- (lint-format "this ~A is either not needed, or is an error: ~A" caller head (truncated-list->string form)))
-
- (if (not (pair? val))
- (cons (make-var :name sym :initial-value val :definer head) env)
- (let ((e (lint-walk (if (and (pair? (car val))
- (eq? (caar val) 'letrec))
- 'define sym)
- (car val) env)))
- (if (or (not (pair? e))
- (eq? e env)
- (not (eq? (var-name (car e)) :lambda))) ; (define x (lambda ...))
- (cons (make-var :name sym :initial-value (car val) :definer head) env)
- (begin
- (set! (var-name (car e)) sym)
-
- (let ((val (caddr form)))
- (when (and (pair? val)
- (eq? (car val) 'lambda) ; (define sym (lambda args (let name...))), let here happens rarely
- (proper-list? (cadr val))
- (pair? (caddr val))
- (null? (cdddr val))
- (eq? (caaddr val) 'let)
- (symbol? (cadr (caddr val))))
- (replace-redundant-named-let caller form sym (cadr val) (caddr val))))
-
- ;; (define x (letrec ((y (lambda...))) (lambda (...) (y...)))) -> (define (x...)...)
- (let* ((let-form (caddr form))
- (var (and (pair? (cadr let-form))
- (null? (cdadr let-form)) ; just one var in let/rec
- (caadr let-form))))
- ;; let-form here can be (lambda...) or (let|letrec ... lambda)
- (when (and (pair? var)
- (symbol? (car var))
- (pair? (cddr let-form))
- (pair? (caddr let-form))
- (null? (cdddr let-form)) ; just one form in the let/rec
- (pair? (cdr var))
- (pair? (cadr var))
- (pair? (cdadr var))
- (eq? (caadr var) 'lambda) ; var is lambda
- (proper-list? (cadadr var))) ; it has no rest arg
- (let ((body (caddr let-form)))
- (when (and (eq? (car body) 'lambda) ; let/rec body is lambda calling var
- (proper-list? (cadr body)) ; rest args are a headache
- (pair? (caddr body))) ; (lambda (...) (...) where car is letrec func name
- (if (eq? (caaddr body) (car var))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(define (,sym ,@(cadr body))
- (let ,(car var)
- ,(map list (cadadr var) (cdaddr body))
- ,@(cddadr var)))))
- (let ((call (find-call (car var) (caddr body))))
- (when (and (pair? call) ; inner lambda body is (...some-expr...(sym...) ...)
- (= (tree-count1 (car var) (caddr body) 0) 1))
- (let ((new-call `(let ,(car var)
- ,(map list (cadadr var) (cdr call))
- ,@(cddadr var))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(define (,sym ,@(cadr body))
- ,(tree-subst new-call call
- (caddr body)))))))))))))
- (when (and *report-function-stuff*
- (pair? (caddr (var-initial-value (car e)))))
- (hash-table-set! equable-closures (caaddr (var-initial-value (car e)))
- (cons (car e) (or (hash-table-ref equable-closures (caaddr (var-initial-value (car e)))) ()))))
- e))))) ; symbol? sym
-
- ;; not (symbol? sym)
- (if (and (pair? sym) ; cadr form
- (pair? val) ; cddr form
- (not (pair? (car sym)))) ; pair would indicate a curried func or something equally stupid
- (let ((outer-args (cdr sym))
- (outer-name (car sym)))
-
- (when (and (pair? (car val))
- (eq? (caar val) 'let)
- (pair? (cadar val)))
- (let ((inner-vars (cadar val)))
- (do ((p outer-args (cdr p)))
- ((not (pair? p)))
- (cond ((assq (car p) inner-vars) =>
- (lambda (v)
- (if (eq? (cadr v) (car p))
- (lint-format "in ~A this let binding is pointless: ~A" caller
- (truncated-list->string form)
- v))))))))
-
- ;; define + redundant named-let -- sometimes rewrites to define*
- (when (and (pair? (car val))
- (eq? (caar val) 'let)
- (symbol? (cadar val))
- (null? (cdr val)))
- (replace-redundant-named-let caller form outer-name outer-args (car val)))
-
- ;; perhaps this block should be on a *report-* switch --
- ;; it translates some internal defines into named lets
- ;; (or just normal lets, etc)
- ;; this is not redundant given the walk-body translations because here
- ;; we have the outer parameters and can check those against the inner ones
- ;; leading (sometimes) to much nicer rewrites.
- (when (and (pair? (car val))
- (eq? (caar val) 'define)
- (pair? (cdr val))
- (pair? (cadar val))) ; inner define (name ...)
- (let ((inner-name (caadar val))
- (inner-args (cdadar val))
- (inner-body (cddar val))
- (outer-body (cdddr form)))
- (when (and (symbol? inner-name)
- (proper-list? inner-args)
- (pair? (car outer-body))
- (= (tree-count1 inner-name outer-body 0) 1))
- (let ((call (find-call inner-name outer-body)))
- (when (pair? call)
- (set! last-rewritten-internal-define (car val))
- (let ((new-call (if (tree-memq inner-name inner-body)
- (if (and (null? inner-args)
- (null? outer-args))
- (if (null? (cdr inner-body))
- (car (tree-subst outer-name inner-name inner-body))
- `(begin ,@(tree-subst outer-name inner-name inner-body)))
- `(let ,inner-name
- ,(if (null? inner-args) () (map list inner-args (cdr call)))
- , at inner-body))
- (if (or (null? inner-args)
- (and (equal? inner-args outer-args)
- (equal? inner-args (cdr call))))
- (if (null? (cdr inner-body))
- (car (tree-subst outer-name inner-name inner-body))
- `(begin ,@(tree-subst outer-name inner-name inner-body)))
- `(let ,(map list inner-args (cdr call))
- , at inner-body)))))
+ (if (and (equal? (cddr body) outer-args)
+ (or (not (hash-table-ref syntaces (cadadr body))) ; (define-macro (x y) `(lambda () ,y))
+ (memq (cadadr body) '(set! define))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(define ,outer-name ,(cadadr body))))
+ (if (and (not (hash-table-ref syntaces (cadadr body)))
+ (not (any-macro? (cadadr body) env))
+ (every? (lambda (a)
+ (or (code-constant? a)
+ (and (memq a outer-args)
+ (= (tree-count1 a (cddr body) 0) 1))))
+ (cddr body)))
+ ;; marginal -- there are many debatable cases here
(lint-format "perhaps ~A" caller
- (lists->string form
- `(,head ,sym
- ,@(let ((p (tree-subst new-call call outer-body)))
- (if (and (pair? p)
- (pair? (car p))
- (eq? (caar p) 'begin))
- (cdar p)
- p)))))))))))
-
- (when (pair? outer-args)
- (if (repeated-member? (proper-list outer-args) env)
- (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string sym)))
-
- (cond ((memq head '(define* define-macro* define-bacro*))
- (check-star-parameters outer-name outer-args env))
- ((list-any? keyword? outer-args)
- (lint-format "~A parameter can't be a keyword: ~A" caller outer-name sym))
- ((memq 'pi outer-args)
- (lint-format "~A parameter can't be a constant: ~A" caller outer-name sym)))
-
- ;; look for built-in names used as parameter names and used as functions internally(!)
- ;; this requires a tree walker to ignore (for example) (let loop ((string string))...)
- (for-each (lambda (p)
- (let ((par (if (pair? p) (car p) p)))
- (when (or (hash-table-ref built-in-functions par)
- (hash-table-ref syntaces par))
- (let ((call (call-with-exit
- (lambda (return)
- (let loop ((tree (cddr form)))
- (if (pair? tree)
- (if (eq? (car tree) par)
- (return tree)
- (case (car tree)
- ((quote) #f)
- ((let let*)
- (if (pair? (cdr tree))
- (if (symbol? (cadr tree))
- (if (not (tree-memq par (caddr tree)))
- (loop (cdddr tree)))
- (if (not (tree-memq par (cadr tree)))
- (loop (cddr tree))))))
- ((letrec letrec*)
- (if (and (pair? (cdr tree))
- (not (tree-memq par (cadr tree))))
- (loop (cddr tree))))
- ((do)
- (if (and (pair? (cdr tree))
- (pair? (cddr tree))
- (not (tree-memq par (cadr tree))))
- (loop (cdddr tree))))
- (else
- (if (pair? (cdr tree))
- (for-each loop (cdr tree)))
- (if (pair? (car tree))
- (loop (car tree))))))))))))
- (if (and (pair? call)
- (pair? (cdr call))
- (not (eq? par (cadr call))))
- (lint-format* caller
- (string-append (object->string outer-name) "'s parameter " (symbol->string par))
- (string-append " is called " (truncated-list->string call))
- ": find a less confusing parameter name!"))))))
- outer-args))
-
- (when (and (eq? head 'define-macro)
- (null? outer-args)
- (null? (cdr val))
- (code-constant? (car val)))
- (lint-format "perhaps ~A" caller (lists->string form `(define ,outer-name ,(car val)))))
-
- (if (and (eq? head 'definstrument)
- (string? (car val)))
- (set! val (cdr val)))
-
- (if (keyword? outer-name)
- (begin
- (lint-format "keywords are constants ~A" caller outer-name)
- env)
- (lint-walk-function head outer-name outer-args val form env)))
-
- (begin
- (lint-format "strange form: ~A" head (truncated-list->string form))
- (when (and (pair? sym)
- (pair? (car sym)))
- (let ((outer-args (cdr sym))
- (outer-name (if (eq? head 'define*) (remove :optional (car sym)) (car sym))))
- (if (symbol? (car outer-name))
- ;; perhaps a curried definition -- as a public service, we'll rewrite the dumb thing
- (begin
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head ,outer-name
- (lambda ,outer-args
- ,@(cddr form)))))
- (lint-walk-function head (car outer-name) (cdr outer-name) val form env)) ;val=(cddr form) I think
- (when (pair? (car outer-name))
- (if (symbol? (caar outer-name))
- (begin
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head ,(car outer-name)
+ (lists->string form `(define (,outer-name , at outer-args)
+ (,(cadadr body) ,@(map unquoted (cddr body)))))))))
+ (let ((pargs (args->proper-list outer-args)))
+ (do ((p (cdr body) (cdr p)))
+ ((null? p))
+ (if (and (pair? (car p))
+ (eq? (caar p) 'quote)
+ (pair? (cdar p))
+ (pair? (cadar p))
+ (tree-set-member pargs (cadar p)))
+ (lint-format "missing comma? ~A" caller form)))))
+
+ ((quote)
+ ;; extra comma (unquote) is already caught elsewhere
+ (if (and (pair? (cdr body))
+ (pair? (cadr body))
+ (tree-set-member (args->proper-list outer-args) (cadr body)))
+ (lint-format "missing comma? ~A" caller form)))))))
+
+ (if (and (eq? head 'definstrument)
+ (string? (car val)))
+ (set! val (cdr val)))
+
+ (if (keyword? outer-name)
+ env
+ (lint-walk-function head outer-name outer-args val form env)))
+
+ (begin ; not (and (pair? sym)...)
+ (lint-format "strange form: ~A" head (truncated-list->string form))
+ (when (and (pair? sym)
+ (pair? (car sym)))
+ (let ((outer-args (cdr sym))
+ (outer-name (if (eq? head 'define*) (remove :optional (car sym)) (car sym))))
+ (if (symbol? (car outer-name))
+ ;; perhaps a curried definition -- as a public service, we'll rewrite the dumb thing
+ (begin
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head ,outer-name
+ (lambda ,outer-args
+ ,@(cddr form)))))
+ (lint-walk-function head (car outer-name) (cdr outer-name) val form env)) ;val=(cddr form) I think
+ (when (pair? (car outer-name))
+ (if (symbol? (caar outer-name))
+ (begin
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head ,(car outer-name)
+ (lambda ,(cdr outer-name)
+ (lambda ,outer-args
+ ,@(cddr form))))))
+ (lint-walk-function head (caar outer-name) (cdar outer-name) val form env))
+ (when (and (pair? (caar outer-name))
+ (symbol? (caaar outer-name)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,head ,(caar outer-name)
+ (lambda ,(cdar outer-name)
(lambda ,(cdr outer-name)
(lambda ,outer-args
- ,@(cddr form))))))
- (lint-walk-function head (caar outer-name) (cdar outer-name) val form env))
- (when (and (pair? (caar outer-name))
- (symbol? (caaar outer-name)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(,head ,(caar outer-name)
- (lambda ,(cdar outer-name)
- (lambda ,(cdr outer-name)
- (lambda ,outer-args
- ,@(cddr form)))))))
- (lint-walk-function head (caaar outer-name) (cdaar outer-name) val form env)))))))
- env))))))
-
- ;; ---------------- lambda ----------------
- ((lambda lambda*)
- (let ((len (length form)))
- (if (< len 3)
- (begin
- (lint-format "~A is messed up in ~A" caller head (truncated-list->string form))
- env)
- (let ((args (cadr form)))
- (when (list? args)
- (let ((arglen (length args)))
- (if (null? args)
- (if (eq? head 'lambda*) ; (lambda* ()...) -> (lambda () ...)
- (lint-format "lambda* could be :lambda ~A" caller form))
- (begin ; args is a pair ; (lambda (a a) ...)
-
- (let ((val (cddr form)))
- (if (and (pair? (car val))
- (eq? (caar val) 'let)
- (pair? (cadar val)))
- (let ((inner-vars (cadar val)))
- (do ((p (cadr form) (cdr p)))
- ((not (pair? p)))
- (cond ((assq (car p) inner-vars) =>
- (lambda (v)
- (if (eq? (cadr v) (car p))
- (lint-format "in ~A this let binding is pointless: ~A" caller
- (truncated-list->string form)
- v)))))))))
-
- (if (repeated-member? (proper-list args) env)
- (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args)))
- (if (eq? head 'lambda*) ; (lambda* (a :b) ...)
- (check-star-parameters head args env)
- (if (list-any? keyword? args) ; (lambda (:key) ...)
- (lint-format "lambda arglist can't handle keywords (use lambda*)" caller)))))
+ ,@(cddr form)))))))
+ (lint-walk-function head (caaar outer-name) (cdaar outer-name) val form env)))))))
+ env))))))
+
+ (for-each (lambda (op)
+ (hash-table-set! h op define-walker))
+ '(define define* define-constant
+ define-macro define-macro* define-bacro define-bacro* define-expansion
+ definstrument defanimal define-envelope ; for clm
+ define-public define*-public defmacro-public define-inlinable
+ define-integrable define^))) ; these give more informative names in Guile and scmutils (MIT-scheme))
+
+
+ ;; ---------------- lambda ----------------
+ (let ()
+ (define (lambda-walker caller form env)
+ (let ((len (length form))
+ (head (car form)))
+ (if (< len 3)
+ (begin
+ (lint-format "~A is messed up in ~A" caller head (truncated-list->string form))
+ env)
+ (let ((args (cadr form)))
+ (when (list? args)
+ (let ((arglen (length args)))
+ (if (null? args)
+ (if (eq? head 'lambda*) ; (lambda* ()...) -> (lambda () ...)
+ (lint-format "lambda* could be lambda ~A" caller form))
+ (begin ; args is a pair ; (lambda (a a) ...)
+
+ (let ((val (cddr form)))
+ (if (and (pair? (car val))
+ (eq? (caar val) 'let)
+ (pair? (cadar val)))
+ (let ((inner-vars (cadar val)))
+ (do ((p (cadr form) (cdr p)))
+ ((not (pair? p)))
+ (cond ((assq (car p) inner-vars) =>
+ (lambda (v)
+ (if (eq? (cadr v) (car p))
+ (lint-format "in ~A this let binding is pointless: ~A" caller
+ (truncated-list->string form)
+ v)))))))))
+
+ (if (repeated-member? (proper-list args) env)
+ (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args)))
+ (if (eq? head 'lambda*) ; (lambda* (a :b) ...)
+ (check-star-parameters head args env)
+ (if (list-any? keyword? args) ; (lambda (:key) ...)
+ (lint-format "lambda arglist can't handle keywords (use lambda*)" caller)))))
+
+ (when (and (eq? head 'lambda) ; (lambda () (f)) -> f, (lambda (a b) (f a b)) -> f
+ (not (eq? caller 'case-lambda))
+ (= len 3)
+ (>= arglen 0)) ; not a dotted list
+ (let ((body (caddr form)))
+ (when (and (pair? body)
+ (symbol? (car body))
+ (not (memq (car body) '(and or))))
+ (cond ((equal? args (cdr body))
+ (lint-format "perhaps ~A" caller (lists->string form (car body))))
+
+ ((equal? (reverse args) (cdr body))
+ (let ((rf (hash-table-ref reversibles (car body))))
+ (if rf (lint-format "perhaps ~A" caller (lists->string form rf)))))
+
+ ((and (= arglen 1)
+ (memq (car body) combinable-cxrs))
+ ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f
+ (and cr
+ (< (length cr) 5)
+ (eq? (car args) arg)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (symbol "c" cr "r")))))
+ (combine-cxrs body)))))))))
+
+ (if (and (or (symbol? args) ; (lambda args (apply f args)) -> f
+ (and (pair? args) ; (lambda #\a ...) !
+ (negative? (length args))))
+ (eq? head 'lambda)
+ (not (eq? caller 'case-lambda))
+ (= len 3))
+ (let ((body (caddr form)))
+ (if (and (pair? body)
+ (eq? (car body) 'apply)
+ (pair? (cdr body))
+ (symbol? (cadr body))
+ (not (memq (cadr body) '(and or)))
+ (pair? (cddr body))
+ (or (eq? args (caddr body))
+ (and (pair? args)
+ (equal? (cddr body) (proper-list args)))))
+ (lint-format "perhaps ~A" caller (lists->string form (cadr body))))))
+
+ (lint-walk-function head caller args (cddr form) form env)
+ ;; not env as return value here -- return the lambda+old env via lint-walk-function
+ ))))
+
+ (hash-table-set! h 'lambda lambda-walker)
+ (hash-table-set! h 'lambda* lambda-walker))
+
+
+ ;; ---------------- set! ----------------
+ (let ()
+ (define (set-walker caller form env)
+ (if (not (= (length form) 3))
+ (begin
+ (lint-format "set! has too ~A arguments: ~S" caller (if (> (length form) 3) "many" "few") form)
+ env)
+ (let ((settee (cadr form))
+ (setval (caddr form)))
+ (let ((result (lint-walk caller setval env)))
+ (if (symbol? settee)
+ (if (constant? settee)
+ (lint-format "can't set! ~A (it is a constant)" caller (truncated-list->string form))
+ (let ((v (var-member settee env)))
+ (if (and (var? v)
+ (eq? (var-definer v) 'define-constant))
+ (lint-format "can't set! ~A in ~A (it is a constant: ~A~A)" caller settee
+ (truncated-list->string form)
+ (if (and (pair? (var-initial-value v))
+ (positive? (pair-line-number (var-initial-value v))))
+ (format #f "(line ~D): " (pair-line-number (var-initial-value v)))
+ "")
+ (truncated-list->string (var-initial-value v))))))
+ (if (not (pair? settee))
+ (lint-format "can't set! ~A" caller (truncated-list->string form))
+ (begin
+ (if (memq (car settee) '(vector-ref list-ref string-ref hash-table-ref))
+ (lint-format "~A as target of set!~A" caller (car settee) (truncated-list->string form)))
+ (lint-walk caller settee env) ; this counts as a reference since it's by reference so to speak
+
+ ;; try type check (dilambda signatures)
+ (when (symbol? (car settee))
+ (let ((f (symbol->value (car settee) *e*)))
+ (when (dilambda? f)
+ (let ((sig (procedure-signature (procedure-setter f)))
+ (settee-len (length settee)))
+ (when (and (pair? sig)
+ (positive? settee-len)
+ (pair? (list-tail sig settee-len)))
+ (let ((checker (list-ref sig settee-len))
+ (arg-type (->lint-type setval)))
+ (when (and (symbol? checker)
+ (not (compatible? checker arg-type)))
+ (lint-format "~A: new value should be a~A ~A: ~S: ~A"
+ caller (car settee)
+ (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
+ checker arg-type
+ (truncated-list->string form)))))))))
+ (set! settee (do ((sym (car settee) (car sym)))
+ ((not (pair? sym)) sym))))))
+
+ (if (symbol? (cadr form)) ; see do directly above -- sets settee so we have to go back to (cadr form)
+ (set-set (cadr form) caller form env)
+ (if (and (pair? (cadr form))
+ (symbol? settee))
+ (set-ref settee caller `(implicit-set ,@(cdr form)) env)))
+
+ (if (equal? (cadr form) setval) ; not settee here!
+ (lint-format "pointless set! ~A" caller (truncated-list->string form)))
+
+ (when (and (pair? setval)
+ (symbol? settee))
+ (case (car setval)
+ ((if) ; (set! x (if y x 1)) -> (if (not y) (set! x 1))
+ (if (= (length setval) 4)
+ (if (eq? settee (caddr setval))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if (not ,(cadr setval)) (set! ,settee ,(cadddr setval)))))
+ (if (eq? settee (cadddr setval))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,(cadr setval) (set! ,settee ,(caddr setval)))))))))
+
+ ((or) ; (set! x (or x y)) -> (if (not x) (set! x y))
+ (if (and (= (length setval) 3) ; the other case here is not improved by using 'if
+ (eq? settee (cadr setval)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if (not ,settee) (set! ,settee ,(caddr setval)))))))
+
+ ((and)
+ (if (= (length setval) 3) ; (set! x (and x y)) -> (if x (set! x y))
+ (if (eq? settee (cadr setval))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,settee (set! ,settee ,(caddr setval)))))
+ (if (eq? settee (caddr setval))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if (not ,(cadr setval)) (set! ,settee #f))))))))))
+ result))))
+ (hash-table-set! h 'set! set-walker))
+
+
+ ;; ---------------- quote ----------------
+ (let ()
+ (define (quote-walker caller form env)
+ (let ((len (length form)))
+ (if (negative? len)
+ (lint-format "stray dot in quote's arguments? ~S" caller form)
+ (if (not (= len 2))
+ (lint-format "quote has too ~A arguments: ~S" caller (if (> len 2) "many" "few") form)
+ (let ((arg (cadr form)))
+ (if (pair? arg)
+ (if (> (length arg) 8)
+ (hash-table-set! big-constants arg (+ 1 (or (hash-table-ref big-constants arg) 0))))
+ (unless (or (>= quote-warnings 20)
+ (and (symbol? arg)
+ (not (keyword? arg))))
+ (set! quote-warnings (+ quote-warnings 1))
+ (lint-format "quote is not needed here: ~A~A" caller ; this is by far the most common message from lint
+ (truncated-list->string form)
+ (if (= quote-warnings 20) "; will ignore this error henceforth." ""))))))))
+ env)
+ (hash-table-set! h 'quote quote-walker))
+
+ ;; ---------------- if ----------------
+ (let ()
+ (define (if-walker caller form env)
+ (let ((len (length form)))
+ (if (> len 4)
+ (lint-format "if has too many clauses: ~A" caller (truncated-list->string form))
+ (if (< len 3)
+ (lint-format "if has too few clauses: ~A" caller (truncated-list->string form))
+ (let ((test (cadr form))
+ (true (caddr form))
+ (false (if (= len 4) (cadddr form) 'no-false))
+ (expr (simplify-boolean (cadr form) () () env))
+ (suggestion made-suggestion))
+
+ (if (eq? false #<unspecified>)
+ (lint-format "this #<unspecified> is redundant: ~A" caller form))
+
+ (if (and (symbol? test)
+ (pair? true)
+ (memq test true))
+ (and-incomplete form 'if test true env)
+ (when (pair? test)
+ (if (and (eq? (car test) 'not)
+ (symbol? (cadr test))
+ (pair? false)
+ (memq (cadr test) false))
+ (and-incomplete form 'if2 (cadr test) false env))
+ (if (and (hash-table-ref bools (car test))
+ (pair? true))
+ (if (member (cadr test) true)
+ (and-forgetful form 'if test true env)
+ (do ((p true (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadr test) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'if test (car p) env)))))
+ (if (and (eq? (car test) 'not)
+ (pair? (cadr test))
+ (pair? false)
+ (hash-table-ref bools (caadr test)))
+ (if (member (cadadr test) false)
+ (and-forgetful form 'if2 (cadr test) false env)
+ (do ((p false (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadadr test) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'if2 (cadr test) (car p) env)))))))))
+
+ (when (and (pair? true)
+ (pair? false)
+ (not (memq (car true) (list 'quote {list})))
+ (not (any-macro? (car true) env))
+ (or (not (hash-table-ref syntaces (car true)))
+ (memq (car true) '(set! and or begin)))
+ (pair? (cdr true)))
+
+ (define (tree-subst-eq new old tree)
+ ;; tree-subst above substitutes every occurence of 'old with 'new, so we check
+ ;; in advance that 'old only occurs once in the tree (via tree-count1). Here
+ ;; 'old may occur any number of times, but we only want to change it once,
+ ;; so we keep the actual pointer to it and use eq?.
+ (cond ((eq? old tree)
+ (cons new (cdr tree)))
+ ((not (pair? tree))
+ tree)
+ ((eq? (car tree) 'quote)
+ (copy-tree tree))
+ (else (cons (tree-subst-eq new old (car tree))
+ (tree-subst-eq new old (cdr tree))))))
+
+ (let ((diff (let differ-in-one ((p true)
+ (q false))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? (car p) (car q))
+ (differ-in-one (cdr p) (cdr q))
+ (and (not (pair? (car p)))
+ (not (pair? (car q)))
+ (equal? (cdr p) (cdr q))
+ (list p (list (car p) (car q)))))))))
+ (if (pair? diff)
+ (unless (or (and (equal? (car true) (caadr diff)) ; (if z (or x (g y)) (and (f x) y))?
+ (or (memq (car true) '(or and))
+ (memq (car false) '(or and))
+ (hash-table-ref syntaces (car true))
+ (hash-table-ref syntaces (car false)))
+ (any? pair? (cdr true)))
+ (and (eq? (car true) 'set!) ; (if x (set! y w) (set! z w))
+ (equal? (caar diff) (cadr true))))
+ ;; also not any-macro? (car true|false) probably
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (cond ((eq? (car true) (caadr diff)) ; very common!
+ ;; (if x (f y) (g y)) -> ((if x f g) y)
+ ;; but f and g can't be or/and unless there are no expressions
+ ;; I now like all of these -- originally found them odd: CL influence!
+ (if (equal? (car true) test)
+ `((or ,test ,(car false)) ,@(cdr true))
+ `((if ,test ,(car true) ,(car false)) ,@(cdr true))))
+
+ ((and (eq? (caadr diff) #t)
+ (not (cadadr diff)))
+ ;; (if x (set! y #t) (set! y #f)) -> (set! y x)
+ (tree-subst-eq test (car diff) true))
+
+ ((and (not (caadr diff))
+ (eq? (cadadr diff) #t))
+ ;; (if x (set! y #f) (set! y #t)) -> (set! y (not x))
+ (tree-subst-eq (simplify-boolean `(not ,expr) () () env)
+ (car diff) true))
+
+ ((equal? (caadr diff) test)
+ ;; (if x (set! y x) (set! y 21)) -> (set! y (or x 21))
+ (tree-subst-eq (simplify-boolean `(or ,@(cadr diff)) () () env)
+ (car diff) true))
+
+ (else
+ ;; (if x (set! y z) (set! y w)) -> (set! y (if x z w))
+ ;; true op moved out, if expr moved in
+ ;; (if A (and B C) (and B D)) -> (and B (if A C D))
+ ;; here differ-in-one means that preceding/trailing stuff must match exactly
+ (tree-subst-eq `(if ,expr ,@(cadr diff)) (car diff) true))))))
- (when (and (eq? head 'lambda) ; (lambda () (f)) -> f, (lambda (a b) (f a b)) -> f
- (not (eq? caller 'case-lambda))
- (= len 3)
- (>= arglen 0)) ; not a dotted list
- (let ((body (caddr form)))
- (when (and (pair? body)
- (symbol? (car body))
- (not (memq (car body) '(and or))))
- (cond ((equal? args (cdr body))
- (lint-format "perhaps ~A" caller (lists->string form (car body))))
-
- ((equal? (reverse args) (cdr body))
- (let ((rf (hash-table-ref reversibles (car body))))
- (if rf (lint-format "perhaps ~A" caller (lists->string form rf)))))
-
- ((and (= arglen 1)
- (memq (car body) '(car cdr caar cadr cddr cdar caaar caadr caddr
- cdddr cdaar cddar cadar cdadr cadddr cddddr)))
- ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f
- (and cr
- (< (length cr) 5)
- (eq? (car args) arg)
- (lint-format "perhaps ~A" caller
- (lists->string form (string->symbol (string-append "c" cr "r"))))))
- (combine-cxrs body)))))))))
-
- (if (and (or (symbol? args) ; (lambda args (apply f args)) -> f
- (and (pair? args) ; (lambda #\a ...) !
- (negative? (length args))))
- (eq? head 'lambda)
- (not (eq? caller 'case-lambda))
- (= len 3))
- (let ((body (caddr form)))
- (if (and (pair? body)
- (eq? (car body) 'apply)
- (pair? (cdr body))
- (symbol? (cadr body))
- (not (memq (cadr body) '(and or)))
- (pair? (cddr body))
- (or (eq? args (caddr body))
- (and (pair? args)
- (equal? (cddr body) (proper-list args)))))
- (lint-format "perhaps ~A" caller (lists->string form (cadr body))))))
-
-#|
- (let ((args1 (args->proper-list args)))
- (when (and (pair? (cddr form))
- (pair? (caddr form))
- (null? (cdddr form))
- (eq? (caaddr form) 'let)
- (pair? (cadr (caddr form))))
- (for-each (lambda (v)
- (if (and (pair? v)
- (pair? (cdr v))
- (pair? (cadr v))
- (not (tree-set-member args1 (cadr v)))
- (memq (caadr v) '(make-vector vector make-string string make-list list)))
- (varlet -- yow)))
- ;; perhaps: cons onto a list passed as another arg to lint-walk-function which walks the body
- ;; and calls report-usage, so at that point we can look at the watched vars. If any are
- ;; not set in any way (and come from list string vector), they can simply be moved to
- ;; the closure. If set, (and from make-*) they can be reinitialized via fill. But,
- ;; we need the fill value -- maybe restrict to large cases? Any unset vals could be
- ;; moved, perhaps removing the need for the let. And for let* et al, they can represent
- ;; the closure too. So (lambda (x) (let ((y (sqrt 2))) (* x y))) -> (let ((y (sqrt 2))) (lambda (x) (* x y)))
- ;; Maybe larger savings from define, but worth a look anyway. Especially wasteful in recursive func.
- ;; even local lets could be moved out -- how to maintain locality?
- (cadr (caddr form))))
-|#
-
- (lint-walk-function head caller args (cddr form) form env)
- ;env -- not this -- return the lambda+old env via lint-walk-function
- ))))
-
- ;; ---------------- set! ----------------
- ((set!)
- (if (not (= (length form) 3))
- (begin
- (lint-format "set! has too ~A arguments: ~S" caller (if (> (length form) 3) "many" "few") form)
- env)
- (let ((settee (cadr form))
- (setval (caddr form)))
- (let ((result (lint-walk caller setval env)))
- (if (symbol? settee)
- (if (constant? settee)
- (lint-format "can't set! ~A (it is a constant)" caller (truncated-list->string form))
- (let ((v (var-member settee env)))
- (if (and (var? v)
- (eq? (var-definer v) 'define-constant))
- (lint-format "can't set! ~A in ~A (it is a constant: ~A~A)" caller settee
- (truncated-list->string form)
- (if (and (pair? (var-initial-value v))
- (positive? (pair-line-number (var-initial-value v))))
- (format #f "(line ~D): " (pair-line-number (var-initial-value v)))
- "")
- (truncated-list->string (var-initial-value v))))))
- (if (not (pair? settee))
- (lint-format "can't set! ~A" caller (truncated-list->string form))
- (begin
- (if (memq (car settee) '(vector-ref list-ref string-ref hash-table-ref))
- (lint-format "~A as target of set!~A" caller (car settee) (truncated-list->string form)))
- (lint-walk caller settee env) ; this counts as a reference since it's by reference so to speak
+ ;; next look for one-seq difference
+ ;; not sure about this -- in simple cases it looks good
+ ;; some cases are trying to remove a test from a loop, so our suggestion will be unwelcome
+
+ (let ((seqdiff (let differ-in-one-seq ((p true)
+ (q false)
+ (c 0))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? (car p) (car q))
+ (differ-in-one-seq (cdr p) (cdr q) (+ c 1))
+ (and (> c 1)
+ (equal? (cdr p) (cdr q))
+ (list p (list (car p) (car q)))))))))
+ ;; (if x (set! y 1) (set! y (+ x 1))) -> (set! y (if x 1 (+ x 1)))
+ (if (pair? seqdiff)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst-eq `(if ,expr ,@(cadr seqdiff)) (car seqdiff) true)))
- ;; try type check (dilambda signatures)
- (when (symbol? (car settee))
- (let ((f (symbol->value (car settee) *e*)))
- (when (dilambda? f)
- (let ((sig (procedure-signature (procedure-setter f)))
- (settee-len (length settee)))
- (when (and (pair? sig)
- (positive? settee-len)
- (pair? (list-tail sig settee-len)))
- (let ((checker (list-ref sig settee-len))
- (arg-type (->lint-type setval)))
- (when (and (symbol? checker)
- (not (compatible? checker arg-type)))
- (lint-format "~A: new value should be a~A ~A: ~S: ~A"
- caller (car settee)
- (if (char=? (string-ref (format #f "~A" checker) 0) #\i) "n" "")
- checker arg-type
- (truncated-list->string form)))))))))
- (set! settee (do ((sym (car settee) (car sym)))
- ((not (pair? sym)) sym))))))
-
- (if (symbol? (cadr form)) ; see do directly above -- sets settee so we have to go back to (cadr form)
- (set-set (cadr form) caller form env)
- (if (and (pair? (cadr form))
- (symbol? settee))
- (set-ref settee caller `(implicit-set ,@(cdr form)) env)))
-
- (if (equal? (cadr form) setval) ; not settee here!
- (lint-format "pointless set! ~A" caller (truncated-list->string form)))
-
- result))))
-
- ;; ---------------- quote ----------------
- ((quote)
- (let ((len (length form)))
- (if (negative? len)
- (lint-format "stray dot in quote's arguments? ~S" caller form)
- (if (not (= len 2))
- (lint-format "quote has too ~A arguments: ~S" caller (if (> len 2) "many" "few") form)
- (let ((arg (cadr form)))
- (if (pair? arg)
- (if (> (length arg) 8)
- (hash-table-set! big-constants arg (+ 1 (or (hash-table-ref big-constants arg) 0))))
- (unless (or (>= quote-warnings 20)
- (and (symbol? arg)
- (not (keyword? arg))))
- (set! quote-warnings (+ quote-warnings 1))
- (lint-format "quote is not needed here: ~A~A" caller
- (truncated-list->string form)
- (if (= quote-warnings 20) "; will ignore this error henceforth." ""))))))))
- env)
-
- ;; ---------------- if ----------------
- ((if)
- (let ((len (length form)))
- (if (> len 4)
- (lint-format "if has too many clauses: ~A" caller (truncated-list->string form))
- (if (< len 3)
- (lint-format "if has too few clauses: ~A" caller (truncated-list->string form))
- (let ((test (cadr form))
- (true (caddr form))
- (false (if (= len 4) (cadddr form) 'no-false))
- (expr (simplify-boolean (cadr form) () () env))
- (suggestion made-suggestion))
-
- (if (eq? false #<unspecified>)
- (lint-format "this #<unspecified> is redundant: ~A" caller form))
-
- (when (and (pair? true)
- (pair? false)
- (not (memq (car true) (list 'quote {list})))
- (not (any-macro? (car true) env))
- (or (not (hash-table-ref syntaces (car true)))
- (memq (car true) '(set! and or begin)))
- (pair? (cdr true)))
-
- (define (tree-subst-eq new old tree)
- ;; tree-subst above substitutes every occurence of 'old with 'new, so we check
- ;; in advance that 'old only occurs once in the tree (via tree-count1). Here
- ;; 'old may occur any number of times, but we only want to change it once,
- ;; so we keep the actual pointer to it and use eq?.
- (cond ((eq? old tree)
- (cons new (cdr tree)))
- ((not (pair? tree))
- tree)
- ((eq? (car tree) 'quote)
- (copy-tree tree))
- (else (cons (tree-subst-eq new old (car tree))
- (tree-subst-eq new old (cdr tree))))))
-
- (let ((diff (let differ-in-one ((p true)
- (q false))
- (and (pair? p)
- (pair? q)
- (if (equal? (car p) (car q))
- (differ-in-one (cdr p) (cdr q))
- (and (not (pair? (car p)))
- (not (pair? (car q)))
- (equal? (cdr p) (cdr q))
- (list p (list (car p) (car q)))))))))
- (if (pair? diff)
- (if (not (or (equal? (car true) (caadr diff)) ; (if z (+ x y) (- x y))?
- (and (eq? (car true) 'set!) ; (if x (set! y w) (set! z w))
- (equal? (caar diff) (cadr true)))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (cond ((and (eq? (caadr diff) #t)
- (not (cadadr diff)))
- ;; (if x (set! y #t) (set! y #f)) -> (set! y x)
- (tree-subst-eq test (car diff) true))
-
- ((and (not (caadr diff))
- (eq? (cadadr diff) #t))
- ;; (if x (set! y #f) (set! y #t)) -> (set! y (not x))
- (tree-subst-eq (simplify-boolean `(not ,expr) () () env)
- (car diff) true))
-
- ((equal? (caadr diff) test)
- ;; (if x (set! y x) (set! y 21)) -> (set! y (or x 21))
- (tree-subst-eq (simplify-boolean `(or ,@(cadr diff)) () () env)
- (car diff) true))
-
- (else
- ;; (if x (set! y z) (set! y w)) -> (set! y (if x z w))
- ;; true op moved out, if expr moved in
- ;; (if A (and B C) (and B D)) -> (and B (if A C D))
- ;; here differ-in-one means that preceding/trailing stuff must match exactly
- (tree-subst-eq `(if ,expr ,@(cadr diff)) (car diff) true))))))
+ ;; differ-in-trailers can (sometimes) take advantage of values
+ (let ((enddiff (let differ-in-trailers ((p true)
+ (q false)
+ (c 0))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? (car p) (car q))
+ (differ-in-trailers (cdr p) (cdr q) (+ c 1))
+ (and (> c 1)
+ (let ((op (if (memq (car true) '(and or + * begin max min)) (car true) 'values)))
+ (list p
+ (if (null? (cdr p)) (car p) `(,op , at p))
+ (if (null? (cdr q)) (car q) `(,op , at q))))))))))
- ;; next look for one-seq difference
- ;; not sure about this -- in simple cases it looks good
- ;; some cases are trying to remove a test from a loop, so our suggestion will be unwelcome
-
- (let ((seqdiff (let differ-in-one-seq ((p true)
- (q false)
- (c 0))
- (and (pair? p)
- (pair? q)
- (if (equal? (car p) (car q))
- (differ-in-one-seq (cdr p) (cdr q) (+ c 1))
- (and (> c 1)
- (equal? (cdr p) (cdr q))
- (list p (list (car p) (car q)))))))))
- ;; (if x (set! y 1) (set! y (+ x 1))) -> (set! y (if x 1 (+ x 1)))
- (if (pair? seqdiff)
- (lint-format "perhaps ~A" caller
- (lists->string form (tree-subst-eq `(if ,expr ,@(cadr seqdiff)) (car seqdiff) true)))
-
- ;; differ-in-trailers can (sometimes) take advantage of values
- (let ((enddiff (let differ-in-trailers ((p true)
- (q false)
- (c 0))
- (and (pair? p)
- (pair? q)
- (if (equal? (car p) (car q))
- (differ-in-trailers (cdr p) (cdr q) (+ c 1))
- (and (> c 1)
- (let ((op (if (memq (car true) '(and or + * begin max min)) (car true) 'values)))
- (list p
- (if (null? (cdr p)) (car p) `(,op , at p))
- (if (null? (cdr q)) (car q) `(,op , at q))))))))))
-
- ;; (if A (+ B C E) (+ B D)) -> (+ B (if A (+ C E) D))
- ;; if p/q null, don't change because for example
- ;; (if A (or B C) (or B C D F)) can't be (or B C (if A ...))
- ;; but if this were not and/or, it could be (+ B (if A C (values C D F)))
- (if (pair? enddiff)
+ ;; (if A (+ B C E) (+ B D)) -> (+ B (if A (+ C E) D))
+ ;; if p/q null, don't change because for example
+ ;; (if A (or B C) (or B C D F)) can't be (or B C (if A ...))
+ ;; but if this were not and/or, it could be (+ B (if A C (values C D F)))
+ (if (pair? enddiff)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst `((if ,expr ,@(cdr enddiff))) (car enddiff) true)))
+
+ ;; differ-in-headers looks for equal trailers
+ ;; (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C)
+ ;; these are not always (read: almost never) an improvement
+ (when (and (eq? (car true) (car false))
+ (not (eq? (car true) 'values))
+ (or (not (eq? (car true) 'set!))
+ (equal? (cadr true) (cadr false))))
+ (let ((headdiff (let differ-in-headers ((p (cdr true))
+ (q (cdr false))
+ (c 0)
+ (rp ())
+ (rq ()))
+ (and (pair? p)
+ (pair? q)
+ (if (equal? p q)
+ (and (> c 0) ; once case is handled elsewhere?
+ (list p (reverse rp) (reverse rq)))
+ (differ-in-headers (cdr p) (cdr q)
+ (+ c 1)
+ (cons (car p) rp) (cons (car q) rq)))))))
+ (when (pair? headdiff)
+ (let* ((op (if (memq (car true) '(and or + * begin max min)) (car true) 'values))
+ (tp (if (null? (cdadr headdiff)) (caadr headdiff) `(,op ,@(cadr headdiff))))
+ (tq (if (null? (cdaddr headdiff)) (caaddr headdiff) `(,op ,@(caddr headdiff)))))
(lint-format "perhaps ~A" caller
- (lists->string form (tree-subst `((if ,expr ,@(cdr enddiff))) (car enddiff) true)))
-
- ;; differ-in-headers looks for equal trailers
- ;; (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C)
- ;; these are not always (read: almost never) an improvement
- (when (and (eq? (car true) (car false))
- (not (eq? (car true) 'values))
- (or (not (eq? (car true) 'set!))
- (equal? (cadr true) (cadr false))))
- (let ((headdiff (let differ-in-headers ((p (cdr true))
- (q (cdr false))
- (c 0)
- (rp ())
- (rq ()))
- (and (pair? p)
- (pair? q)
- (if (equal? p q)
- (and (> c 0) ; once case is handled elsewhere?
- (list p (reverse rp) (reverse rq)))
- (differ-in-headers (cdr p) (cdr q)
- (+ c 1)
- (cons (car p) rp) (cons (car q) rq)))))))
- (when (pair? headdiff)
- (let* ((op (if (memq (car true) '(and or + * begin max min)) (car true) 'values))
- (tp (if (null? (cdadr headdiff)) (caadr headdiff) `(,op ,@(cadr headdiff))))
- (tq (if (null? (cdaddr headdiff)) (caaddr headdiff) `(,op ,@(caddr headdiff)))))
- (lint-format "perhaps ~A" caller
- (lists->string form `(,(car true) (if ,expr ,tp ,tq) ,@(car headdiff)))))))))))))))
-
- (unless (= last-if-line-number line-number)
- (do ((iff form (cadddr iff))
- (iffs 0 (+ iffs 1)))
- ((not (and (<= iffs 2)
- (pair? iff)
- (= (length iff) 4)
- (eq? (car iff) 'if)))
- (when (or (> iffs 2)
- (and (= iffs 2)
- (pair? iff)
- (= (length iff) 3)
- (eq? (car iff) 'if)))
- (set! last-if-line-number line-number)
- (lint-format "perhaps use cond: ~A" caller
- (lists->string form
- `(cond ,@(do ((iff form (cadddr iff))
- (clauses ()))
- ((not (and (pair? iff)
- (= (length iff) 4)
- (eq? (car iff) 'if)))
- (append (reverse clauses)
- (if (and (pair? iff)
- (= (length iff) 3)
- (eq? (car iff) 'if))
- `((,(cadr iff) ,@(unbegin (caddr iff))))
- `((else ,@(unbegin iff))))))
- (set! clauses (cons (cons (cadr iff) (unbegin (caddr iff))) clauses))))))))))
-
- (if (never-false test)
- (lint-format "if test is never false: ~A" caller (truncated-list->string form))
- (if (and (never-true test) true) ; complain about (if #f #f) later
- (lint-format "if test is never true: ~A" caller (truncated-list->string form))))
+ (lists->string form `(,(car true) (if ,expr ,tp ,tq) ,@(car headdiff)))))))))))))))
+
+ (unless (= last-if-line-number line-number)
+ (do ((iff form (cadddr iff))
+ (iffs 0 (+ iffs 1)))
+ ((not (and (<= iffs 2)
+ (pair? iff)
+ (= (length iff) 4)
+ (eq? (car iff) 'if)))
+ (when (or (> iffs 2)
+ (and (= iffs 2)
+ (pair? iff)
+ (= (length iff) 3)
+ (eq? (car iff) 'if)))
+ (set! last-if-line-number line-number)
+ (lint-format "perhaps use cond: ~A" caller
+ (lists->string form
+ `(cond ,@(do ((iff form (cadddr iff))
+ (clauses ()))
+ ((not (and (pair? iff)
+ (= (length iff) 4)
+ (eq? (car iff) 'if)))
+ (append (reverse clauses)
+ (if (and (pair? iff)
+ (= (length iff) 3)
+ (eq? (car iff) 'if))
+ `((,(cadr iff) ,@(unbegin (caddr iff))))
+ `((else ,@(unbegin iff))))))
+ (set! clauses (cons (cons (cadr iff) (unbegin (caddr iff))) clauses))))))))))
+
+ (if (never-false test)
+ (lint-format "if test is never false: ~A" caller (truncated-list->string form))
+ (if (and (never-true test) true) ; complain about (if #f #f) later
+ (lint-format "if test is never true: ~A" caller (truncated-list->string form))))
+
+ (unless (side-effect? test env)
+ (cond ((or (equal? test true) ; (if x x y) -> (or x y)
+ (equal? expr true))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean (if (eq? false 'no-false)
+ `(or ,expr #<unspecified>)
+ `(or ,expr ,false))
+ () () env))))
+ ((or (equal? test `(not ,true)) ; (if x (not x) y) -> (and (not x) y)
+ (equal? `(not ,test) true)) ; (if (not x) x y) -> (and x y)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean (if (eq? false 'no-false)
+ `(and ,true #<unspecified>)
+ `(and ,true ,false))
+ () () env))))
+ ((or (equal? test false) ; (if x y x) -> (and x y)
+ (equal? expr false))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (simplify-boolean `(and ,expr ,true) () () env))))
- (unless (side-effect? test env)
- (cond ((or (equal? test true) ; (if x x y) -> (or x y)
- (equal? expr true))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (simplify-boolean (if (eq? false 'no-false)
- `(or ,expr #<unspecified>)
- `(or ,expr ,false))
- () () env))))
- ((or (equal? test `(not ,true)) ; (if x (not x) y) -> (and (not x) y)
- (equal? `(not ,test) true)) ; (if (not x) x y) -> (and x y)
- (lint-format "perhaps ~A" caller
- (lists->string form
- (simplify-boolean (if (eq? false 'no-false)
- `(and ,true #<unspecified>)
- `(and ,true ,false))
- () () env))))
- ((or (equal? test false) ; (if x y x) -> (and x y)
- (equal? expr false))
+ ((or (equal? `(not ,test) false) ; (if x y (not x)) -> (or (not x) y)
+ (equal? test `(not ,false))) ; (if (not x) y x) -> (or x y)
+ (lint-format "perhaps ~A" caller
+ (lists->string form (simplify-boolean `(or ,false ,true) () () env))))))
+
+ (when (= len 4)
+ (when (and (pair? true)
+ (eq? (car true) 'if))
+ (let ((true-test (cadr true))
+ (true-true (caddr true)))
+ (if (= (length true) 4)
+ (let ((true-false (cadddr true)))
+ (if (equal? expr (simplify-boolean `(not ,true-test) () () env))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,expr ,true-false ,false))))
+ (if (equal? expr true-test)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,expr ,true-true ,false))))
+ (if (equal? false true-false)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean
+ (if (not false)
+ `(and ,expr ,true-test ,true-true)
+ `(if (and ,expr ,true-test) ,true-true ,false))
+ () () env)))
+ (if (equal? false true-true)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (simplify-boolean
+ (if (not false)
+ `(and ,expr (not ,true-test) ,true-false)
+ `(if (and ,expr (not ,true-test)) ,true-false ,false))
+ () () env)))))
+
+ ;; (if a (if b d e) (if c d e)) -> (if (if a b c) d e)? reversed does not happen.
+ ;; (if a (if b d) (if c d)) -> (if (if a b c) d)
+ ;; (if a (if b d e) (if (not b) d e)) -> (if (eq? (not a) (not b)) d e)
+ (if (and (pair? false)
+ (eq? (car false) 'if)
+ (= (length false) 4)
+ (not (equal? true-test (cadr false)))
+ (equal? (cddr true) (cddr false)))
+ (let ((false-test (cadr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? true-test)
+ (eq? (car true-test) 'not)
+ (equal? (cadr true-test) false-test))
+ `(if (not (eq? (not ,expr) ,true-test))
+ ,@(cddr true))
+ (if (and (pair? false-test)
+ (eq? (car false-test) 'not)
+ (equal? true-test (cadr false-test)))
+ `(if (eq? (not ,expr) ,false-test)
+ ,@(cddr true))
+ `(if (if ,expr ,true-test ,false-test) ,@(cddr true)))))))))
+
+ (begin
+ (if (equal? expr (simplify-boolean `(not ,true-test) () () env))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if (not ,expr) ,false))))
+ (if (equal? expr true-test)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,expr ,true-true ,false))))
+ (if (equal? false true-true) ; (if a (if b A) A)
+ (lint-format "perhaps ~A" caller
+ (let ((nexpr (simplify-boolean `(or (not ,expr) ,true-test) () () env)))
+ (lists->string form `(if ,nexpr ,false)))))))))
+
+ (when (pair? false)
+ (case (car false)
+ ((cond) ; (if a A (cond...)) -> (cond (a A) ...)
+ (lint-format "perhaps ~A" caller (lists->string form `(cond (,expr ,true) ,@(cdr false)))))
+
+ ((if)
+ (when (= (length false) 4)
+ (let ((false-test (cadr false))
+ (false-true (caddr false))
+ (false-false (cadddr false)))
+ (if (equal? true false-true)
+ (lint-format "perhaps ~A" caller
+ (if (and (pair? false-false)
+ (eq? (car false-false) 'if)
+ (equal? true (caddr false-false)))
+ (lists->string form
+ (let ((nexpr (simplify-boolean
+ `(or ,expr ,false-test ,(cadr false-false))
+ () () env)))
+ `(if ,nexpr ,true ,@(cdddr false-false))))
+ (if true
+ (let ((nexpr (simplify-boolean `(or ,expr ,false-test) () () env)))
+ (lists->string form `(if ,nexpr ,true ,false-false)))
+ (lists->string form
+ (simplify-boolean
+ `(and (not (or ,expr ,false-test)) ,false-false)
+ () () env)))))
+ (if (equal? true false-false)
+ (lint-format "perhaps ~A" caller
+ (if true
+ (let ((nexpr (simplify-boolean `(or ,expr (not ,false-test)) () () env)))
+ (lists->string form `(if ,nexpr ,true ,false-true)))
+ (lists->string form
+ (simplify-boolean
+ `(and (not (or ,expr (not ,false-test))) ,false-true)
+ () () env))))))))
+ (if (and (pair? true)
+ (eq? (car true) 'if)
+ (= (length true) 3)
+ (= (length false) 3)
+ (equal? (cddr true) (cddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(if (if ,expr ,(cadr true) ,(cadr false)) ,@(cddr true))))))
+
+ ((map) ; (if (null? x) () (map abs x)) -> (map abs x)
+ (if (and (pair? test)
+ (eq? (car test) 'null?)
+ (or (null? true)
+ (equal? true (cadr test)))
+ (equal? (cadr test) (caddr false))
+ (or (null? (cdddr false))
+ (not (side-effect? (cdddr false) env))))
+ (lint-format "perhaps ~A" caller (lists->string form false))))
+
+ ((case)
+ (if (and (pair? expr)
+ (cond-eqv? expr (cadr false) #t))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(case ,(cadr false)
+ ,(case-branch expr (cadr false) (list true))
+ ,@(cddr false))))))))
+ ) ; (= len 4)
+
+ (if (pair? false)
+ (let ((false-test (and (pair? (cdr false)) (cadr false))))
+ (if (and (eq? (car false) 'if) ; (if x 3 (if (not x) 4)) -> (if x 3 4)
+ (pair? (cdr false))
+ (not (side-effect? test env)))
+ (if (or (equal? test false-test)
+ (equal? expr false-test))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,expr ,true ,@(cdddr false))))
+ (if (and (pair? false-test)
+ (eq? (car false-test) 'not)
+ (or (equal? test (cadr false-test))
+ (equal? expr (cadr false-test))))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,expr ,true ,(caddr false)))))))
+
+ (if (and (eq? (car false) 'if) ; (if test0 expr (if test1 expr)) -> if (or test0 test1) expr)
+ (null? (cdddr false)) ; other case is dealt with above
+ (equal? true (caddr false)))
+ (let ((test1 (simplify-boolean `(or ,expr ,false-test) () () env)))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,test1 ,true ,@(cdddr false)))))))
+
+ (when (and (eq? false 'no-false) ; no false branch
+ (pair? true))
+ (if (pair? test)
+ (let ((test-op (car test))
+ (true-op (car true)))
+ ;; the min+max case is seldom hit, and takes about 50 lines
+ (if (and (memq test-op '(< > <= >=)) ; (if (< x y) (set! x y) -> (set! x (max x y))
+ (eq? true-op 'set!)
+ (null? (cdddr test))
+ (memq (cadr true) test)
+ (member (caddr true) test))
+ (let* ((target (cadr true))
+ (f (if (eq? target ((if (memq test-op '(< <=)) cadr caddr) test))
+ 'max 'min)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(set! ,target (,f ,@(cdr true)))))))))
+
+ (if (eq? (car true) 'if) ; (if test0 (if test1 expr)) -> (if (and test0 test1) expr)
+ (cond ((null? (cdddr true))
+ (let ((test1 (simplify-boolean `(and ,expr ,(cadr true)) () () env)))
+ (lint-format "perhaps ~A" caller (lists->string form `(if ,test1 ,(caddr true))))))
+
+ ((equal? expr (cadr true))
+ (lint-format "perhaps ~A" caller (lists->string form true)))
+
+ ((equal? (cadr true) `(not ,expr))
(lint-format "perhaps ~A" caller
- (lists->string form (simplify-boolean `(and ,expr ,true) () () env))))
-
- ((or (equal? `(not ,test) false) ; (if x y (not x)) -> (or (not x) y)
- (equal? test `(not ,false))) ; (if (not x) y x) -> (or x y)
+ (lists->string form (cadddr true)))))
+
+ (if (memq (car true) '(when unless)) ; (if test0 (when test1 expr...)) -> (when (and test0 test1) expr...)
+ (let ((test1 (simplify-boolean (if (eq? (car true) 'when)
+ `(and ,expr ,(cadr true))
+ `(and ,expr (not ,(cadr true))))
+ () () env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? test1)
+ (eq? (car test1) 'not))
+ `(unless ,(cadr test1) ,@(cddr true))
+ `(when ,test1 ,@(cddr true))))))))))
+ (if (and (pair? test)
+ (memq (car test) '(< <= > >= =)) ; (if (< x y) x y) -> (min x y)
+ (null? (cdddr test))
+ (member false test)
+ (member true test))
+ (if (eq? (car test) '=) ; (if (= x y) y x) -> y [this never happens]
+ (lint-format "perhaps ~A" caller (lists->string form false))
+ (let ((f (if (equal? (cadr test) (if (memq (car test) '(< <=)) true false))
+ 'min 'max)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,f ,true ,false))))))
+
+ (cond ((eq? expr #t)
+ (lint-format "perhaps ~A" caller (lists->string form true)))
+
+ ((not expr)
+ (if (eq? false 'no-false)
+ (if true ; (if #f x) as a kludgey #<unspecified>
+ (lint-format "perhaps ~A" caller (lists->string form #<unspecified>)))
+ (lint-format "perhaps ~A" caller (lists->string form false))))
+
+ ((not (equal? true false))
+ (if (boolean? true)
+ (if (boolean? false) ; ! (if expr #t #f) turned into something less verbose
+ (lint-format "perhaps ~A" caller
+ (lists->string form (if true
+ expr
+ (simplify-boolean `(not ,expr) () () env))))
+ (when (= suggestion made-suggestion)
(lint-format "perhaps ~A" caller
- (lists->string form (simplify-boolean `(or ,false ,true) () () env))))))
-
- (when (= len 4)
- (when (and (pair? true)
- (eq? (car true) 'if))
- (if (= (length true) 4)
+ (lists->string form (if true
+ (if (eq? false 'no-false)
+ expr
+ (simplify-boolean `(or ,expr ,false) () () env))
+ (simplify-boolean
+ (if (eq? false 'no-false)
+ `(not ,expr)
+ `(and (not ,expr) ,false))
+ () () env))))))
+ (if (and (boolean? false)
+ (= suggestion made-suggestion))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (simplify-boolean
+ (if false
+ (if (and (pair? expr) (eq? (car expr) 'not))
+ `(or ,(cadr expr) ,true)
+ `(or (not ,expr) ,true))
+ `(and ,expr ,true))
+ () () env))))))
+ ((= len 4)
+ (lint-format "if is not needed here: ~A" caller
+ (lists->string form (if (not (side-effect? test env))
+ true
+ `(begin ,expr ,true))))))
+
+ (when (and (= suggestion made-suggestion)
+ (not (equal? expr test))) ; make sure the boolean simplification gets reported
+ (lint-format "perhaps ~A" caller (lists->string test expr)))
+
+ (if (and (pair? test)
+ (pair? true)
+ (pair? (cdr true))
+ (null? (cddr true))
+ (or (equal? test (cadr true))
+ (equal? expr (cadr true))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? false 'no-false)
+ `(cond (,expr => ,(car true)))
+ `(cond (,expr => ,(car true)) (else ,false))))))
+
+ (when (and (pair? true)
+ (pair? false)
+ (eq? (car true) 'if)
+ (eq? (car false) 'if)
+ (= (length true) (length false) 4)
+ (equal? (cadr true) (cadr false)))
+ (if (and (equal? (caddr true) (cadddr false)) ; (if A (if B a b) (if B b a)) -> (if (eq? (not A) (not B)) a b)
+ (equal? (cadddr true) (caddr false)))
+ (let* ((switch #f)
+ (a (if (and (pair? expr)
+ (eq? (car expr) 'not))
+ (begin (set! switch #t) expr)
+ (simplify-boolean `(not ,expr) () () env)))
+ (b (if (and (pair? (cadr true))
+ (eq? (caadr true) 'not))
+ (begin (set! switch (not switch)) (cadr true))
+ (simplify-boolean `(not ,(cadr true)) () () env))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if switch
+ `(if (eq? ,a ,b) ,(caddr false) ,(caddr true))
+ `(if (eq? ,a ,b) ,(caddr true) ,(caddr false))))))
+ (unless (or (side-effect? expr env)
+ (equal? (cddr true) (cddr false))) ; handled elsewhere
+ (if (equal? (caddr true) (caddr false)) ; (if A (if B a b) (if B a c)) -> (if B a (if A b c))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(if ,(cadr true) ,(caddr true)
+ (if ,expr ,(cadddr true) ,(cadddr false)))))
+ (if (equal? (cadddr true) (cadddr false)) ; (if A (if B a b) (if B c b)) -> (if B (if A a c) b)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(if ,(cadr true)
+ (if ,expr ,(caddr true) ,(caddr false))
+ ,(cadddr true)))))))))
+ ;; --------
+ (when (and (= suggestion made-suggestion)
+ (not (= line-number last-if-line-number)))
+ ;; unravel complicated if-then-else nestings into a single cond, if possible.
+ ;;
+ ;; The (> new-len *report-nested-if*) below can mean (nearly) all nested ifs are turned into conds.
+ ;; For a long time I thought the if form was easier to read, but now
+ ;; I like cond better. But cond also has serious readability issues:
+ ;; it needs to be clearer where the test separates from the result,
+ ;; and in a stack of these clauses, it's hard to see anything at all.
+ ;; Maybe a different color for the test than the result?
+ ;;
+ ;; Also, the check for tree-leaves being hugely different is taken
+ ;; from C -- I think it is easier to read a large if statement if
+ ;; the shortest clause is at the start -- especially in a nested if where
+ ;; it can be nearly impossible to see which dangling one-liner matches
+ ;; which if (this even in emacs because it unmarks or doesn't remark the matching
+ ;; paren as you're trying to scroll up to it).
+ ;;
+ ;; the cond form is not always an improvement:
+ ;; (if A (if B (if C a b) (if C c d)) (if B (if C e f) (if C g h)))
+ ;; (cond (A (cond (B (cond (C a) (else b))) ... oh forget it ...))))
+ ;; perhaps: (case (+ (if A 4 0) (if B 2 0) (if C 1 0)) ((#b000)...))!
+ ;; how often (and how deeply nested) does this happen? -- not very, but nesting can be ridiculous.
+ ;; and this assumes all tests are always hit
+
+ (define (swap-clauses form)
+ (if (not (pair? (cdddr form)))
+ form
+ (let ((expr (cadr form))
+ (true (caddr form))
+ (false (cadddr form)))
+
+ (let ((true-n (tree-leaves true))
+ (false-n (if (not (pair? false))
+ 1
+ (tree-leaves false))))
+
+ (if (< false-n (/ true-n 4))
+ (let ((new-expr (simplify-boolean `(not ,expr) () () env)))
+ (if (and (pair? true)
+ (eq? (car true) 'if))
+ (set! true (swap-clauses true)))
+ (if (and (pair? true)
+ (eq? (car true) 'cond))
+ `(cond (,new-expr ,@(unbegin false))
+ ,@(cdr true))
+ `(cond (,new-expr ,@(unbegin false))
+ (else ,@(unbegin true)))))
(begin
- (if (equal? expr (simplify-boolean `(not ,(cadr true)) () () env))
- (lint-format "perhaps ~A" caller
- (lists->string form `(if ,expr ,(cadddr true) ,false))))
- (if (equal? expr (cadr true))
- (lint-format "perhaps ~A" caller
- (lists->string form `(if ,expr ,(caddr true) ,false))))
- (if (equal? false (cadddr true))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (simplify-boolean
- (if (not false)
- `(and ,expr ,(cadr true) ,(caddr true))
- `(if (and ,expr ,(cadr true)) ,(caddr true) ,false))
- () () env)))
- (if (equal? false (caddr true))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (simplify-boolean
- (if (not false)
- `(and ,expr (not ,(cadr true)) ,(cadddr true))
- `(if (and ,expr (not ,(cadr true))) ,(cadddr true) ,false))
- () () env)))))
-
- ;; (if a (if b d e) (if c d e)) -> (if (if a b c) d e)? reversed does not happen.
- ;; (if a (if b d) (if c d)) -> (if (if a b c) d)
- ;; (if a (if b d e) (if (not b) d e)) -> (if (eq? (not a) (not b)) d e)
(if (and (pair? false)
- (eq? (car false) 'if)
- (= (length false) 4)
- (not (equal? (cadr true) (cadr false)))
- (equal? (cddr true) (cddr false)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (pair? (cadr true))
- (eq? (caadr true) 'not)
- (equal? (cadadr true) (cadr false)))
- `(if (not (eq? (not ,expr) ,(cadr true)))
- ,@(cddr true))
- (if (and (pair? (cadr false))
- (eq? (caadr false) 'not)
- (equal? (cadr true) (cadadr false)))
- `(if (eq? (not ,expr) ,(cadr false))
- ,@(cddr true))
- `(if (if ,expr ,(cadr true) ,(cadr false)) ,@(cddr true))))))))
-
- (begin
- (if (equal? expr (simplify-boolean `(not ,(cadr true)) () () env))
- (lint-format "perhaps ~A" caller
- (lists->string form `(if (not ,expr) ,false))))
- (if (equal? expr (cadr true))
- (lint-format "perhaps ~A" caller
- (lists->string form `(if ,expr ,(caddr true) ,false))))
- (if (equal? false (caddr true)) ; (if a (if b A) A)
- (lint-format "perhaps ~A" caller
- (let ((nexpr (simplify-boolean `(or (not ,expr) ,(cadr true)) () () env)))
- (lists->string form `(if ,nexpr ,false))))))))
-
- (when (pair? false)
- (case (car false)
- ((cond) ; (if a A (cond...)) -> (cond (a A) ...)
- (lint-format "perhaps ~A" caller (lists->string form `(cond (,expr ,true) ,@(cdr false)))))
-
- ((if)
- (when (= (length false) 4)
- (if (equal? true (caddr false))
- (lint-format "perhaps ~A" caller
- (if (and (pair? (cadddr false))
- (eq? (car (cadddr false)) 'if)
- (equal? true (caddr (cadddr false))))
- (lists->string form
- (let ((nexpr (simplify-boolean
- `(or ,expr ,(cadr false) ,(cadr (cadddr false)))
- () () env)))
- `(if ,nexpr ,true ,@(cdddr (cadddr false)))))
- (if true
- (let ((nexpr (simplify-boolean `(or ,expr ,(cadr false)) () () env)))
- (lists->string form `(if ,nexpr ,true ,(cadddr false))))
- (lists->string form
- (simplify-boolean
- `(and (not (or ,expr ,(cadr false))) ,(cadddr false))
- () () env)))))
- (if (equal? true (cadddr false))
- (lint-format "perhaps ~A" caller
- (if true
- (let ((nexpr (simplify-boolean `(or ,expr (not ,(cadr false))) () () env)))
- (lists->string form `(if ,nexpr ,true ,(caddr false))))
- (lists->string form
- (simplify-boolean
- `(and (not (or ,expr (not ,(cadr false)))) ,(caddr false))
- () () env)))))))
- (if (and (pair? true)
- (eq? (car true) 'if)
- (= (length true) 3)
- (= (length false) 3)
- (equal? (cddr true) (cddr false)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(if (if ,expr ,(cadr true) ,(cadr false)) ,@(cddr true))))))
-
-
- ((map) ; (if (null? x) () (map abs x)) -> (map abs x)
- (if (and (pair? test)
- (eq? (car test) 'null?)
- (or (null? true)
- (equal? true (cadr test)))
- (equal? (cadr test) (caddr false))
- (or (null? (cdddr false))
- (not (side-effect? (cdddr false) env))))
- (lint-format "perhaps ~A" caller (lists->string form false))))
-
- ((case)
- (if (and (pair? expr)
- (cond-eqv? expr (cadr false) #t))
- (lint-format "perhaps ~A" caller
- (lists->string form `(case ,(cadr false)
- ,(case-branch expr (cadr false) (list true))
- ,@(cddr false))))))))
- ) ; (= len 4)
-
- (if (pair? false)
+ (eq? (car false) 'if))
+ (set! false (swap-clauses false)))
+
+ (if (and (pair? false)
+ (eq? (car false) 'cond))
+ `(cond (,expr ,@(unbegin true))
+ ,@(cdr false))
+ `(cond (,expr ,@(unbegin true))
+ (else ,@(unbegin false))))))))))
+
+ (let ((new-if (swap-clauses form)))
+ (if (eq? (car new-if) 'cond)
+ (if (> (length new-if) *report-nested-if*)
(begin
- (if (and (eq? (car false) 'if) ; (if x 3 (if (not x) 4)) -> (if x 3 4)
- (pair? (cdr false))
- (not (side-effect? test env)))
- (if (or (equal? test (cadr false))
- (equal? expr (cadr false)))
- (lint-format "perhaps ~A" caller (lists->string form `(if ,expr ,true ,@(cdddr false))))
- (if (and (pair? (cadr false))
- (eq? (caadr false) 'not)
- (or (equal? test (cadadr false))
- (equal? expr (cadadr false))))
- (lint-format "perhaps ~A" caller (lists->string form `(if ,expr ,true ,(caddr false)))))))
-
- (if (and (eq? (car false) 'if) ; (if test0 expr (if test1 expr)) -> if (or test0 test1) expr)
- (null? (cdddr false)) ; other case is dealt with above
- (equal? true (caddr false)))
- (let ((test1 (simplify-boolean `(or ,expr ,(cadr false)) () () env)))
- (lint-format "perhaps ~A" caller (lists->string form `(if ,test1 ,true ,@(cdddr false)))))))
+ (set! last-if-line-number line-number)
+ (lint-format "perhaps ~A" caller (lists->string form new-if)))
- (when (and (eq? false 'no-false) ; no false branch
- (pair? true))
- (if (pair? test)
- (let ((test-op (car test))
- (true-op (car true)))
- ;; the min+max case is seldom hit, and takes about 50 lines
- (if (and (memq test-op '(< > <= >=)) ; (if (< x y) (set! x y) -> (set! x (max x y))
- (eq? true-op 'set!)
- (null? (cdddr test))
- (memq (cadr true) test)
- (member (caddr true) test))
- (let* ((target (cadr true))
- (f (if (eq? target (if (memq test-op '(< <=))
- (cadr test)
- (caddr test)))
- 'max 'min)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(set! ,target (,f ,@(cdr true)))))))))
-
- (if (eq? (car true) 'if) ; (if test0 (if test1 expr)) -> (if (and test0 test1) expr)
- (cond ((null? (cdddr true))
- (let ((test1 (simplify-boolean `(and ,expr ,(cadr true)) () () env)))
- (lint-format "perhaps ~A" caller (lists->string form `(if ,test1 ,(caddr true))))))
-
- ((equal? expr (cadr true))
- (lint-format "perhaps ~A" caller (lists->string form true)))
-
- ((equal? (cadr true) `(not ,expr))
- (lint-format "perhaps ~A" caller
- (lists->string form (cadddr true)))))
-
- (if (memq (car true) '(when unless)) ; (if test0 (when test1 expr...)) -> (when (and test0 test1) expr...)
- (let ((test1 (simplify-boolean (if (eq? (car true) 'when)
- `(and ,expr ,(cadr true))
- `(and ,expr (not ,(cadr true))))
- () () env)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (pair? test1)
- (eq? (car test1) 'not))
- `(unless ,(cadr test1) ,@(cddr true))
- `(when ,test1 ,@(cddr true))))))))))
-
- (if (and (pair? test)
- (memq (car test) '(< <= > >= =)) ; (if (< x y) x y) -> (min x y)
- (null? (cdddr test))
- (member false test)
- (member true test))
- (if (eq? (car test) '=) ; (if (= x y) y x) -> y [this never happens]
- (lint-format "perhaps ~A" caller (lists->string form false))
- (let ((f (if (equal? (cadr test) (if (memq (car test) '(< <=)) true false))
- 'min 'max)))
- (lint-format "perhaps ~A" caller (lists->string form `(,f ,true ,false))))))
-
- (cond ((eq? expr #t)
- (lint-format "perhaps ~A" caller (lists->string form true)))
-
- ((not expr)
- (if (eq? false 'no-false)
- (if true ; (if #f x) as a kludgey #<unspecified>
- (lint-format "perhaps ~A" caller (lists->string form #<unspecified>)))
- (lint-format "perhaps ~A" caller (lists->string form false))))
-
- ((not (equal? true false))
- (if (boolean? true)
- (if (boolean? false) ; ! (if expr #t #f) turned into something less verbose
- (lint-format "perhaps ~A" caller
- (lists->string form (if true
- expr
- (simplify-boolean `(not ,expr) () () env))))
- (when (= suggestion made-suggestion)
- (lint-format "perhaps ~A" caller
- (lists->string form (if true
- (if (eq? false 'no-false)
- expr
- (simplify-boolean `(or ,expr ,false) () () env))
- (simplify-boolean
- (if (eq? false 'no-false)
- `(not ,expr)
- `(and (not ,expr) ,false))
- () () env))))))
- (if (and (boolean? false)
- (= suggestion made-suggestion))
- (lint-format "perhaps ~A" caller
- (lists->string form (simplify-boolean
- (if false
- (if (and (pair? expr) (eq? (car expr) 'not))
- `(or ,(cadr expr) ,true)
- `(or (not ,expr) ,true))
- `(and ,expr ,true))
- () () env))))))
- ((= len 4)
- (lint-format "if is not needed here: ~A" caller
- (lists->string form (if (not (side-effect? test env))
- true
- `(begin ,expr ,true))))))
-
- (when (and (= suggestion made-suggestion)
- (not (equal? expr test))) ; make sure the boolean simplification gets reported
- (lint-format "perhaps ~A" caller (lists->string test expr)))
-
- (if (and (pair? test)
- (pair? true)
- (pair? (cdr true))
- (null? (cddr true))
- (or (equal? test (cadr true))
- (equal? expr (cadr true))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (eq? false 'no-false)
- `(cond (,expr => ,(car true)))
- `(cond (,expr => ,(car true)) (else ,false))))))
-
- (when (and (pair? true)
- (pair? false)
- (eq? (car true) 'if)
- (eq? (car false) 'if)
- (= (length true) (length false) 4)
- (equal? (cadr true) (cadr false)))
- (if (and (equal? (caddr true) (cadddr false)) ; (if A (if B a b) (if B b a)) -> (if (eq? (not A) (not B)) a b)
- (equal? (cadddr true) (caddr false)))
- (let* ((switch #f)
- (a (if (and (pair? expr)
- (eq? (car expr) 'not))
- (begin (set! switch #t) expr)
- (simplify-boolean `(not ,expr) () () env)))
- (b (if (and (pair? (cadr true))
- (eq? (caadr true) 'not))
- (begin (set! switch (not switch)) (cadr true))
- (simplify-boolean `(not ,(cadr true)) () () env))))
+ (when (= len 4)
+ (let ((true-len (tree-leaves (caddr form))))
+ (if (and (> true-len *report-short-branch*)
+ (< (tree-leaves (cadddr form)) (/ true-len *report-short-branch*)))
+ (let ((new-expr (simplify-boolean `(not ,(cadr form)) () () env)))
+ (lint-format "perhaps place the much shorter branch first~A: ~A" caller
+ (local-line-number (cadr form))
+ (truncated-lists->string form `(if ,new-expr ,false ,true))))))))))
+ ;; --------
+
+ (when (= len 4)
+ ;; move repeated test to top, if no inner false branches
+ ;; (if A (if B C) (if B D)) -> (if B (if A C D))
+ (when (and (pair? true)
+ (pair? false)
+ (eq? (car true) 'if)
+ (eq? (car false) 'if)
+ (equal? (cadr true) (cadr false))
+ (null? (cdddr true))
+ (null? (cdddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,(cadr (caddr form))
+ (if ,expr
+ ,(caddr (caddr form))
+ ,(caddr (cadddr form)))))))
+
+ ;; move repeated start/end statements out of the if
+ (let ((true (if (and (pair? true) (eq? (car true) 'begin)) true (list 'begin true)))
+ (false (if (and (pair? false) (eq? (car false) 'begin)) false (list 'begin false))))
+ (let ((true-len (length true))
+ (false-len (length false)))
+ (let ((start (if (and (equal? (cadr true) (cadr false))
+ (not (side-effect? expr env))) ; expr might affect start, so we can't pull it ahead
+ (list (cadr true))
+ ()))
+ (end (if (and (not (= true-len false-len 2))
+ (equal? (list-ref true (- true-len 1))
+ (list-ref false (- false-len 1))))
+ (list (list-ref true (- true-len 1)))
+ ())))
+ (when (or (pair? start)
+ (pair? end))
+ (let ((new-true (cdr true))
+ (new-false (cdr false)))
+ (when (pair? end)
+ (set! new-true (copy new-true (make-list (- true-len 2)))) ; (copy lst ()) -> ()
+ (set! new-false (copy new-false (make-list (- false-len 2)))))
+ (when (pair? start)
+ (if (pair? new-true) (set! new-true (cdr new-true)))
+ (if (pair? new-false) (set! new-false (cdr new-false))))
+ (when (or (pair? end)
+ (and (pair? new-true)
+ (pair? new-false))) ; otherwise the rewrite changes the returned value
+ (if (pair? new-true)
+ (set! new-true (if (null? (cdr new-true))
+ (car new-true)
+ (cons 'begin new-true))))
+ (if (pair? new-false)
+ (set! new-false (if (null? (cdr new-false))
+ (car new-false)
+ (cons 'begin new-false))))
(lint-format "perhaps ~A" caller
(lists->string form
- (if switch
- `(if (eq? ,a ,b) ,(caddr false) ,(caddr true))
- `(if (eq? ,a ,b) ,(caddr true) ,(caddr false))))))
- (unless (or (side-effect? expr env)
- (equal? (cddr true) (cddr false))) ; handled elsewhere
- (if (equal? (caddr true) (caddr false)) ; (if A (if B a b) (if B a c)) -> (if B a (if A b c))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(if ,(cadr true) ,(caddr true)
- (if ,expr ,(cadddr true) ,(cadddr false)))))
- (if (equal? (cadddr true) (cadddr false)) ; (if A (if B a b) (if B c b)) -> (if B (if A a c) b)
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(if ,(cadr true)
- (if ,expr ,(caddr true) ,(caddr false))
- ,(cadddr true)))))))))
-
- (when (and (symbol? test) ; (if x (map f x)) -- very common
- (pair? true)
- (pair? (cdr true)))
- (if (and (memq (car true) '(map for-each))
- (pair? (cddr true))
- (eq? test (caddr true)))
- (lint-format "perhaps ~A" caller
- (truncated-lists->string form `(if (sequence? ,expr) ,@(cddr form))))
- (if (and (eq? test (cadr true))
- (not (eq? form last-assoc-form)) ; why isn't this redundant?
- (hash-table-ref built-in-functions (car true)))
- (let ((sig (procedure-signature (car true))))
- (if (and (pair? sig)
- (symbol? (cadr sig))
- (not (memq (cadr sig) '(boolean? input-port? output-port?)))
- (not (and (var-member test env)
- (tree-set-car-member '(assoc assv assq) (var-history (var-member test env))))))
- (lint-format "perhaps ~A" caller
- (truncated-lists->string form `(if (,(cadr sig) ,expr) ,@(cddr form)))))))))
- ;; the parallel if-not case does not happen
-
- ;; --------
- (when (and (= suggestion made-suggestion)
- (not (= line-number last-if-line-number)))
- ;; unravel complicated if-then-else nestings into a single cond, if possible.
- ;;
- ;; The (> new-len *report-nested-if*) below can mean (nearly) all nested ifs are turned into conds.
- ;; For a long time I thought the if form was easier to read, but now
- ;; I like cond better. But cond also has serious readability issues:
- ;; it needs to be clearer where the test separates from the result,
- ;; and in a stack of these clauses, it's hard to see anything at all.
- ;; Maybe a different color for the test than the result?
- ;;
- ;; Also, the check for tree-leaves being hugely different is taken
- ;; from C -- I think it is easier to read a large if statement if
- ;; the shortest clause is at the start -- especially in a nested if where
- ;; it can be nearly impossible to see which dangling one-liner matches
- ;; which if (this even in emacs because it unmarks or doesn't remark the matching
- ;; paren as you're trying to scroll up to it).
- ;;
- ;; the cond form is not always an improvement:
- ;; (if A (if B (if C a b) (if C c d)) (if B (if C e f) (if C g h)))
- ;; (cond (A (cond (B (cond (C a) (else b))) ... oh forget it ...))))
- ;; perhaps: (case (+ (if A 4 0) (if B 2 0) (if C 1 0)) ((#b000)...))!
- ;; how often (and how deeply nested) does this happen? -- not very, but nesting can be ridiculous.
- ;; and this assumes all tests are always hit
-
- (define (swap-clauses form)
- (if (not (pair? (cdddr form)))
- form
- (let ((expr (cadr form))
- (true (caddr form))
- (false (cadddr form)))
-
- (let ((true-n (tree-leaves true))
- (false-n (if (not (pair? false))
- 1
- (tree-leaves false))))
-
- (if (< false-n (/ true-n 4))
- (let ((new-expr (simplify-boolean `(not ,expr) () () env)))
- (if (and (pair? true)
- (eq? (car true) 'if))
- (set! true (swap-clauses true)))
- (if (and (pair? true)
- (eq? (car true) 'cond))
- `(cond (,new-expr ,@(unbegin false))
- ,@(cdr true))
- `(cond (,new-expr ,@(unbegin false))
- (else ,@(unbegin true)))))
- (begin
- (if (and (pair? false)
- (eq? (car false) 'if))
- (set! false (swap-clauses false)))
-
- (if (and (pair? false)
- (eq? (car false) 'cond))
- `(cond (,expr ,@(unbegin true))
- ,@(cdr false))
- `(cond (,expr ,@(unbegin true))
- (else ,@(unbegin false))))))))))
-
- (let ((new-if (swap-clauses form)))
- (if (eq? (car new-if) 'cond)
- (if (> (length new-if) *report-nested-if*)
- (begin
- (set! last-if-line-number line-number)
- (lint-format "perhaps ~A" caller (lists->string form new-if)))
-
- (if (= len 4) ; unneccessary?
- (let ((true-len (tree-leaves (caddr form))))
- (if (and (> true-len *report-short-branch*)
- (< (tree-leaves (cadddr form)) (/ true-len *report-short-branch*)))
- (let ((new-expr (simplify-boolean `(not ,(cadr form)) () () env)))
- (lint-format "perhaps place the much shorter branch first~A: ~A" caller
- (local-line-number (cadr form))
- (truncated-lists->string form `(if ,new-expr ,false ,true))))))))))
- ;; --------
-
- (if (and (= len 4) ; move repeated test to top, if no inner false branches
- (pair? true) ; (if A (if B C) (if B D)) -> (if B (if A C D))
- (pair? false)
- (eq? (car true) 'if)
- (eq? (car false) 'if)
- (equal? (cadr true) (cadr false))
- (null? (cdddr true))
- (null? (cdddr false)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(if ,(cadr (caddr form))
- (if ,expr
- ,(caddr (caddr form))
- ,(caddr (cadddr form)))))))
-
- (when (and (= len 4) ; move repeated start/end statements out of the if
- (pair? true)
- (pair? false)
- (eq? (car true) 'begin)
- (eq? (car false) 'begin))
- (let ((true-len (length true))
- (false-len (length false)))
- (when (and (> true-len 2)
- (> false-len 2))
- (let ((start (if (and (equal? (cadr true) (cadr false))
- (not (side-effect? expr env))) ; expr might affect start, so we can't pull it ahead
- (list (cadr true))
- ()))
- (end (if (equal? (list-ref true (- true-len 1))
- (list-ref false (- false-len 1)))
- (list (list-ref true (- true-len 1)))
- ())))
- (when (or (pair? start)
- (pair? end))
- (let ((new-true (cdr true))
- (new-false (cdr false)))
- (when (pair? end)
- (set! new-true (copy new-true (make-list (- true-len 2))))
- (set! new-false (copy new-false (make-list (- false-len 2)))))
- (when (pair? start)
- (set! new-true (cdr new-true))
- (set! new-false (cdr new-false)))
- (set! new-true (if (null? (cdr new-true))
- (car new-true)
- (cons 'begin new-true)))
- (set! new-false (if (null? (cdr new-false))
- (car new-false)
- (cons 'begin new-false)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(begin , at start
- (if ,expr ,new-true ,new-false)
- , at end)))))))))
-
- (if (and (= suggestion made-suggestion) ; (if (not a) A B) -> (if a B A)
- (not (= line-number last-if-line-number))
- (= len 4)
- (pair? expr)
- (eq? (car expr) 'not)
- (> (tree-leaves true) (tree-leaves false)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(if ,(cadr expr) ,false ,true))))
-
- ;; this happens occasionally -- scarcely worth this much code! (gather copied vars outside the if)
- ;; TODO: this should check that the gathered code does not affect the original test
- (when (and (= len 4)
- (pair? true)
- (pair? false)
- (eq? (car true) 'let)
- (eq? (car false) 'let)
- (pair? (cadr true))
- (pair? (cadr false)))
- (let ((true-vars (map car (cadr true)))
- (false-vars (map car (cadr false)))
- (shared-vars ()))
- (for-each (lambda (v)
- (if (and (memq v false-vars)
- (equal? (cadr (assq v (cadr true)))
- (cadr (assq v (cadr false)))))
- (set! shared-vars (cons v shared-vars))))
- true-vars)
- (when (pair? shared-vars)
- ;; now remake true/false lets (maybe nil) without shared-vars
- (let ((ntv ())
- (nfv ())
- (sv ()))
- (for-each (lambda (v)
- (if (memq (car v) shared-vars)
- (set! sv (cons v sv))
- (set! ntv (cons v ntv))))
- (cadr true))
- (set! ntv (if (or (pair? ntv)
- (pair? (cdddr true))) ; even define is safe here because outer let blocks it just as inner let used to
- `(let (,@(reverse ntv)) ,@(cddr true))
- (caddr true)))
- (for-each (lambda (v)
- (if (not (memq (car v) shared-vars))
- (set! nfv (cons v nfv))))
- (cadr false))
- (set! nfv (if (or (pair? nfv)
- (pair? (cdddr false)))
- `(let (,@(reverse nfv)) ,@(cddr false))
- (caddr false)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(let (,@(reverse sv)) (if ,expr ,ntv ,nfv)))))))))
-
- (if (and *report-one-armed-if*
- (eq? false 'no-false)
- (or (not (integer? *report-one-armed-if*))
- (> (tree-leaves true) *report-one-armed-if*)))
- (lint-format "~A~A~A perhaps ~A" caller
- (if (integer? *report-one-armed-if*)
- "this one-armed if is too big"
- "")
- (local-line-number test)
- (if (integer? *report-one-armed-if*) ";" "")
- (truncated-lists->string
- form (if (and (pair? expr)
- (eq? (car expr) 'not))
- `(unless ,(cadr expr) ,@(unbegin true))
- `(when ,expr ,@(unbegin true))))))
-
- (if (symbol? expr)
- (set-ref expr caller form env)
- (lint-walk caller expr env))
- (set! env (lint-walk caller true env))
- (if (= len 4) (set! env (lint-walk caller false env))))))
- env))
+ (let ((body (if (null? new-true)
+ `(if (not ,expr) ,new-false)
+ (if (null? new-false)
+ `(if ,expr ,new-true)
+ `(if ,expr ,new-true ,new-false)))))
+ `(begin , at start
+ ,body
+ , at end))))))))))
+
+ (when (and (= suggestion made-suggestion) ; (if (not a) A B) -> (if a B A)
+ (not (= line-number last-if-line-number))
+ (pair? expr)
+ (eq? (car expr) 'not)
+ (> (tree-leaves true) (tree-leaves false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(if ,(cadr expr) ,false ,true))))
+
+ ;; this happens occasionally -- scarcely worth this much code! (gather copied vars outside the if)
+ (when (and (pair? true)
+ (pair? false)
+ (eq? (car true) 'let)
+ (eq? (car false) 'let)
+ (pair? (cadr true))
+ (pair? (cadr false)))
+ (let ((true-vars (map car (cadr true)))
+ (false-vars (map car (cadr false)))
+ (shared-vars ()))
+ (for-each (lambda (v)
+ (if (and (memq v false-vars)
+ (equal? (cadr (assq v (cadr true)))
+ (cadr (assq v (cadr false)))))
+ (set! shared-vars (cons v shared-vars))))
+ true-vars)
+ (when (pair? shared-vars)
+ ;; now remake true/false lets (maybe nil) without shared-vars
+ (let ((ntv ())
+ (nfv ())
+ (sv ()))
+ (for-each (lambda (v)
+ (if (memq (car v) shared-vars)
+ (set! sv (cons v sv))
+ (set! ntv (cons v ntv))))
+ (cadr true))
+ (set! ntv (if (or (pair? ntv)
+ (pair? (cdddr true))) ; even define is safe here because outer let blocks it just as inner let used to
+ `(let (,@(reverse ntv)) ,@(cddr true))
+ (caddr true)))
+ (for-each (lambda (v)
+ (if (not (memq (car v) shared-vars))
+ (set! nfv (cons v nfv))))
+ (cadr false))
+ (set! nfv (if (or (pair? nfv)
+ (pair? (cdddr false)))
+ `(let (,@(reverse nfv)) ,@(cddr false))
+ (caddr false)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (not (or (side-effect? expr env)
+ (tree-set-member (map car sv) expr)))
+ `(let (,@(reverse sv)) (if ,expr ,ntv ,nfv))
+ (let ((uniq (find-unique-name form)))
+ `(let ((,uniq ,expr))
+ (let (,@(reverse sv))
+ (if ,uniq ,ntv ,nfv)))))))))))))
+
+ (when (and *report-one-armed-if*
+ (eq? false 'no-false)
+ (or (not (integer? *report-one-armed-if*))
+ (> (tree-leaves true) *report-one-armed-if*)))
+ (lint-format "~A~A~A perhaps ~A" caller
+ (if (integer? *report-one-armed-if*)
+ "this one-armed if is too big"
+ "")
+ (local-line-number test)
+ (if (integer? *report-one-armed-if*) ";" "")
+ (truncated-lists->string
+ form (if (and (pair? expr)
+ (eq? (car expr) 'not))
+ `(unless ,(cadr expr) ,@(unbegin true))
+ `(when ,expr ,@(unbegin true))))))
+
+ (if (symbol? expr)
+ (set-ref expr caller form env)
+ (lint-walk caller expr env))
+ (set! env (lint-walk caller true env))
+ (if (= len 4)
+ (set! env (lint-walk caller false env))))))
+ env))
+ (hash-table-set! h 'if if-walker))
+
+
+ ;; -------- when, unless --------
+ (let ()
+ (define (when-walker caller form env)
+ (if (< (length form) 3)
+ (begin
+ (lint-format "~A is messed up: ~A" caller (car form) (truncated-list->string form))
+ env)
+ (let ((test (cadr form))
+ (head (car form)))
+ (if (and (pair? test)
+ (eq? (car test) 'not))
+ (lint-format "perhaps ~A -> ~A"
+ caller
+ (truncated-list->string form)
+ (truncated-list->string `(,(if (eq? head 'when) 'unless 'when)
+ ,(cadr test)
+ ,@(cddr form)))))
+ (if (never-false test)
+ (lint-format "~A test is never false: ~A" caller head form)
+ (if (never-true test)
+ (lint-format "~A test is never true: ~A" caller head form)))
- ;; -------- when, unless --------
- ((when unless)
- (if (< (length form) 3)
- (begin
- (lint-format "~A is messed up: ~A" caller head (truncated-list->string form))
- env)
- (let ((test (cadr form)))
- (if (and (pair? test)
- (eq? (car test) 'not))
- (lint-format "perhaps ~A -> ~A"
- caller
- (truncated-list->string form)
- (truncated-list->string `(,(if (eq? head 'when) 'unless 'when)
- ,(cadr test)
- ,@(cddr form)))))
- (if (never-false test)
- (lint-format "~A test is never false: ~A" caller head form)
- (if (never-true test)
- (lint-format "~A test is never true: ~A" caller head form)))
-
- (if (symbol? test)
- (set-ref test caller form env)
- (if (pair? test)
- (lint-walk caller test env)))
-
- (if (and (pair? (cddr form)) ; (when t1 (if t2 A)) -> (when (and t1 t2) A)
- (null? (cdddr form))
- (pair? (caddr form)))
- (let ((body (caddr form)))
- (if (or (memq (car body) '(when unless))
- (and (eq? (car body) 'if)
- (pair? (cdr body))
- (pair? (cddr body))
- (null? (cdddr body))))
- (let* ((inner-test (if (eq? (car body) 'unless)
- `(not ,(cadr body))
- (cadr body)))
- (outer-test (if (eq? head 'unless)
- `(not ,test)
- test))
- (new-test (simplify-boolean `(and ,outer-test ,inner-test) () () env)))
+ (if (symbol? test)
+ (begin
+ (set-ref test caller form env)
+ (if (and (eq? head 'when)
+ (pair? (cddr form))
+ (pair? (caddr form)))
+ (if (memq test (caddr form))
+ (and-incomplete form head test (caddr form) env)
+ (do ((p (caddr form) (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (memq test (car p))))
+ (if (pair? p)
+ (and-incomplete form head test (car p) env)))))))
+ (if (pair? test)
+ (lint-walk caller test env)))
+
+ (if (and (pair? (cddr form)) ; (when t1 (if t2 A)) -> (when (and t1 t2) A)
+ (null? (cdddr form))
+ (pair? (caddr form)))
+ (let ((body (caddr form)))
+ (if (or (memq (car body) '(when unless))
+ (and (eq? (car body) 'if)
+ (pair? (cdr body))
+ (pair? (cddr body))
+ (null? (cdddr body))))
+ (let* ((inner-test (if (eq? (car body) 'unless)
+ `(not ,(cadr body))
+ (cadr body)))
+ (outer-test (if (eq? head 'unless)
+ `(not ,test)
+ test))
+ (new-test (simplify-boolean `(and ,outer-test ,inner-test) () () env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (pair? new-test)
+ (eq? (car new-test) 'not))
+ `(unless ,(cadr new-test) ,@(cddr body))
+ `(when ,new-test ,@(cddr body)))))))))
+ (lint-walk-open-body caller head (cddr form) env))))
+ (hash-table-set! h 'when when-walker)
+ (hash-table-set! h 'unless when-walker))
+
+
+ ;; ---------------- cond ----------------
+ (let ()
+ (define (cond-walker caller form env)
+ (let ((ctr 0)
+ (suggest made-suggestion)
+ (len (- (length form) 1)))
+ (if (< len 1)
+ (lint-format "cond is messed up: ~A" caller (truncated-list->string form))
+ (let ((exprs ())
+ (result :unset)
+ (has-else #f)
+ (has-combinations #f)
+ (simplifications ())
+ (prev-clause #f)
+ (all-eqv #t)
+ (eqv-select #f))
+
+ ;; (cond (A (and B C)) (else (and B D))) et al never happens
+ ;; also (cond (A C) (B C)) -> (if (or A B) C) [non-pair C]
+ ;; ----------------
+ ;; if regular cond + else
+ ;; scan all return blocks
+ ;; if all one form, and either header or trailer always match,
+ ;; rewrite as header + cond|if + trailer
+ ;; given values and the presence of else, every possibility is covered
+ ;; at least (car result) has to match across all
+ (when (and (> len 1) ; (cond (else ...)) is handled elsewhere
+ (pair? (cdr form))
+ (pair? (cadr form))
+ (not (tree-set-member '(unquote #_{list}) form)))
+ (let ((first-clause (cadr form))
+ (else-clause (list-ref form len)))
+ (when (and (pair? (cdr first-clause))
+ (null? (cddr first-clause))
+ (pair? (cadr first-clause))
+ (pair? else-clause))
+ (let ((first-result (cadr first-clause))
+ (first-func (caadr first-clause)))
+ (if (and (memq (car else-clause) '(#t else))
+ (pair? (cdr else-clause))
+ (pair? (cadr else-clause))
+ (or (equal? (caadr first-clause) (caadr else-clause)) ; there's some hope we'll match
+ (escape? (cadr else-clause) env)))
+ (let ((else-error (escape? (cadr else-clause) env)))
+ (when (and (pair? (cdr first-result))
+ (not (eq? first-func 'values))
+ (or (not (hash-table-ref syntaces first-func))
+ (eq? first-func 'set!))
+ (every? (lambda (c)
+ (and (pair? c)
+ (pair? (cdr c))
+ (pair? (cadr c))
+ (null? (cddr c))
+ (pair? (cdadr c))
+ (or (equal? first-func (caadr c))
+ (and (eq? c else-clause)
+ else-error))))
+ (cddr form)))
+ ((lambda (header-len trailer-len result-min-len)
+ (when (and (or (not (eq? first-func 'set!))
+ (> header-len 1))
+ (or (not (eq? first-func '/))
+ (> header-len 1)
+ (> trailer-len 0)))
+ (let ((header (copy first-result (make-list header-len)))
+ (trailer (copy first-result (make-list trailer-len) (- (length first-result) trailer-len))))
+ (if (= len 2)
+ (unless (equal? first-result (cadr else-clause)) ; handled elsewhere (all results equal -> result)
+ (lint-format "perhaps ~A" caller
+ (let ((else-result (cadr else-clause)))
+ (let ((first-mid-len (- (length first-result) header-len trailer-len))
+ (else-mid-len (- (length else-result) header-len trailer-len)))
+ (let ((fmid (if (= first-mid-len 1)
+ (list-ref first-result header-len)
+ `(values ,@(copy first-result (make-list first-mid-len) header-len))))
+ (emid (if else-error
+ else-result
+ (if (= else-mid-len 1)
+ (list-ref else-result header-len)
+ `(values ,@(copy else-result (make-list else-mid-len) header-len))))))
+ (lists->string form `(, at header (if ,(car first-clause) ,fmid ,emid) , at trailer)))))))
+ ;; len > 2 so use cond in the revision
+ (let ((middle (map (lambda (c)
+ (let ((test (car c))
+ (result (cadr c)))
+ (let ((mid-len (- (length result) header-len trailer-len)))
+ (if (and else-error
+ (eq? c else-clause))
+ else-clause
+ `(,test ,(if (= mid-len 1)
+ (list-ref result header-len)
+ `(values ,@(copy result (make-list mid-len) header-len))))))))
+ (cdr form))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(, at header (cond , at middle) , at trailer))))))))
+ (partition-form (cdr form) (if else-error (- len 1) len)))))
+
+ ;; not escaping else here because the trailing args might be evaluated first
+ (when (and (not (hash-table-ref syntaces (car first-result)))
+ (every? (lambda (c)
+ (and (pair? c)
+ (pair? (cdr c))
+ (pair? (cadr c))
+ (null? (cddr c))
+ (not (hash-table-ref syntaces (caadr c)))
+ (equal? (cdadr c) (cdr first-result))))
+ (cddr form)))
+ (if (every? (lambda (c)
+ (eq? first-func (caadr c))) ; all result clauses are the same!?
+ (cddr form)) ; possibly no else, so not always a duplicate message
(lint-format "perhaps ~A" caller
(lists->string form
- (if (and (pair? new-test)
- (eq? (car new-test) 'not))
- `(unless ,(cadr new-test) ,@(cddr body))
- `(when ,new-test ,@(cddr body)))))))))
- (lint-walk-open-body caller head (cddr form) env))))
-
- ;; ---------------- cond ----------------
- ((cond)
- (let ((ctr 0)
- (suggest made-suggestion)
- (len (- (length form) 1)))
- (if (negative? len)
- (lint-format "cond is messed up: ~A" caller (truncated-list->string form))
- (let ((exprs ())
- (result :unset)
- (has-else #f)
- (has-combinations #f)
- (simplifications ())
- (prev-clause #f)
- (all-eqv #t)
- (eqv-select #f))
-
- ;; (cond (A (and B C)) (else (and B D))) et al never happens
- ;; ----------------
- ;; if regular cond + else
- ;; scan all return blocks
- ;; if all one form, and either header or trailer always match,
- ;; rewrite as header + cond|if + trailer
- ;; given values and the presence of else, every possibility is covered
- ;; at least (car result) has to match across all
- (when (and (> len 1) ; (cond (else ...)) is handled elsewhere
- (pair? (cdr form))
- (pair? (cadr form))
- (not (tree-set-member '(unquote #_{list}) form)))
- (let ((first-clause (cadr form))
- (else-clause (list-ref form len)))
- (when (and (pair? (cdr first-clause))
- (null? (cddr first-clause))
- (pair? (cadr first-clause))
- (pair? else-clause)
- (memq (car else-clause) '(#t else))
- (pair? (cdr else-clause))
- (pair? (cadr else-clause))
- (or (equal? (caadr first-clause) (caadr else-clause)) ; there's some hope we'll match
- (escape? (cadr else-clause) env)))
- (let ((first-result (cadr first-clause))
- (first-func (caadr first-clause))
- (else-error (escape? (cadr else-clause) env)))
- (when (and (pair? (cdr first-result))
- (not (eq? first-func 'values))
- (or (not (hash-table-ref syntaces first-func))
- (eq? first-func 'set!))
- (every? (lambda (c)
- (and (pair? c)
- (pair? (cdr c))
- (pair? (cadr c))
- (null? (cddr c))
- (pair? (cdadr c))
- (or (equal? first-func (caadr c))
- (and (eq? c else-clause)
- else-error))))
- (cddr form)))
- ((lambda (header-len trailer-len result-min-len)
- (when (and (or (not (eq? first-func 'set!))
- (> header-len 1))
- (or (not (eq? first-func '/))
- (> header-len 1)
- (> trailer-len 0)))
- (let ((header (copy first-result (make-list header-len)))
- (trailer (copy first-result (make-list trailer-len) (- (length first-result) trailer-len))))
- (if (= len 2)
- (unless (equal? first-result (cadr else-clause)) ; handled elsewhere (all results equal -> result)
- (lint-format "perhaps ~A" caller
- (let ((else-result (cadr else-clause)))
- (let ((first-mid-len (- (length first-result) header-len trailer-len))
- (else-mid-len (- (length else-result) header-len trailer-len)))
- (let ((fmid (if (= first-mid-len 1)
- (list-ref first-result header-len)
- `(values ,@(copy first-result (make-list first-mid-len) header-len))))
- (emid (if else-error
- else-result
- (if (= else-mid-len 1)
- (list-ref else-result header-len)
- `(values ,@(copy else-result (make-list else-mid-len) header-len))))))
- (lists->string form `(, at header (if ,(car first-clause) ,fmid ,emid) , at trailer)))))))
- ;; len > 2 so use cond in the revision
- (let ((middle (map (lambda (c)
- (let ((test (car c))
- (result (cadr c)))
- (let ((mid-len (- (length result) header-len trailer-len)))
- (if (and else-error
- (eq? c else-clause))
- else-clause
- `(,test ,(if (= mid-len 1)
- (list-ref result header-len)
- `(values ,@(copy result (make-list mid-len) header-len))))))))
- (cdr form))))
- (lint-format "perhaps ~A" caller
- (lists->string form `(, at header (cond , at middle) , at trailer))))))))
- (partition-form (cdr form) (if else-error (- len 1) len))))))))
- ;; ----------------
-
- (let ((falses ())
- (trues ()))
- (for-each
- (lambda (clause)
- (set! ctr (+ ctr 1))
- (if (not (pair? clause))
- (begin
- (set! all-eqv #f)
- (set! has-combinations #f)
- (lint-format "cond clause ~A in ~A is not a pair?" caller clause (truncated-list->string form)))
- (begin
+ `(if (or ,@(map car (cdr form)))
+ ,first-result)))
+ ;; here we need an else clause else (apply #<unspecified> args)
+ (if (memq (car else-clause) '(#t else))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `((cond ,@(map (lambda (c)
+ (list (car c) (caadr c)))
+ (cdr form)))
+ ,@(cdr first-result))))))))))))
+ ;; ----------------
+
+ (let ((falses ())
+ (trues ()))
+ (for-each
+ (lambda (clause)
+ (set! ctr (+ ctr 1))
+ (if (not (pair? clause))
+ (begin
+ (set! all-eqv #f)
+ (set! has-combinations #f)
+ (lint-format "cond clause ~A in ~A is not a pair?" caller clause (truncated-list->string form)))
+ (begin
+
+ (when all-eqv
+ (unless eqv-select
+ (set! eqv-select (eqv-selector (car clause))))
+ (set! all-eqv (and eqv-select
+ (not (and (pair? (cdr clause))
+ (eq? (cadr clause) '=>))) ; case sends selector, but cond sends test result
+ (cond-eqv? (car clause) eqv-select #t))))
+
+ (if (and (pair? prev-clause)
+ (not has-combinations)
+ (> len 2)
+ (equal? (cdr clause) (cdr prev-clause)))
+ (if (memq (car clause) '(else #t)) ; (cond ... (x z) (else z)) -> (cond ... (else z))
+ (unless (side-effect? (car prev-clause) env)
+ (lint-format* caller
+ "this clause could be omitted: "
+ (truncated-list->string prev-clause)))
+ (set! has-combinations #t))) ; handle these later
+ (set! prev-clause clause)
+
+ (let ((expr (simplify-boolean (car clause) trues falses env))
+ (test (car clause))
+ (sequel (cdr clause)))
+ (if (not (equal? expr test))
+ (set! simplifications (cons (cons clause expr) simplifications)))
+
+ ;; (not x) case rarely happens?
+ (if (symbol? test)
+ (if (and (not (eq? test 'else))
+ (pair? sequel)
+ (pair? (car sequel)))
+ (if (memq test (car sequel))
+ (and-incomplete form 'cond test (car sequel) env)
+ (do ((p (car sequel) (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (memq test (car p))))
+ (if (pair? p)
+ (and-incomplete form 'cond test (car p) env))))))
+ (if (and (pair? test)
+ (hash-table-ref bools (car test))
+ (pair? sequel)
+ (pair? (car sequel)))
+ (if (member (cadr test) (car sequel))
+ (and-forgetful form 'cond test (car sequel) env)
+ (do ((p (car sequel) (cdr p)))
+ ((or (not (pair? p))
+ (and (pair? (car p))
+ (member (cadr test) (car p))))
+ (if (pair? p)
+ (and-forgetful form 'cond test (car p) env)))))))
+
+ (cond ((memq test '(else #t))
+ (set! has-else #t)
+
+ (if (and (pair? sequel)
+ (eq? (car sequel) #<unspecified>))
+ (lint-format "this #<unspecified> is redundant: ~A" caller clause))
+
+ (if (and (pair? sequel) ; (cond (a A) (else (cond ...))) -> (cond (a A) ...)
+ (pair? (car sequel)) ; similarly for if, when, and unless
+ (null? (cdr sequel)))
+ (case (caar sequel)
+ ((cond)
+ (lint-format "else clause could be folded into the outer cond: ~A" caller
+ (lists->string form (append (copy form (make-list ctr))
+ (cdar sequel)))))
+ ((if)
+ (let ((if-expr (car sequel)))
+ (lint-format "else clause could be folded into the outer cond: ~A" caller
+ (lists->string form
+ (append (copy form (make-list ctr))
+ (if (= (length if-expr) 3)
+ (list (cdr if-expr))
+ `((,(cadr if-expr) ,@(unbegin (caddr if-expr)))
+ (else ,@(unbegin (cadddr if-expr))))))))))
+ ((when unless)
+ (lint-format "else clause could be folded into the outer cond: ~A" caller
+ (lists->string form
+ (append (copy form (make-list ctr))
+ (if (eq? (caar sequel) 'when)
+ `((,(cadar sequel) ,@(cddar sequel)))
+ `(((not ,(cadar sequel)) ,@(cddar sequel)))))))))))
+ ((and (equal? test ''else)
+ (= ctr len))
+ (lint-format "odd cond clause test: is 'else supposed to be else? ~A" caller
+ (truncated-list->string clause)))
+
+ ((and (eq? test 't)
+ (= ctr len)
+ (not (var-member 't env)))
+ (lint-format "odd cond clause test: is t supposed to be #t? ~A" caller
+ (truncated-list->string clause))))
+
+ (if (never-false expr)
+ (if (not (= ctr len))
+ (lint-format "cond test ~A is never false: ~A" caller (car clause) (truncated-list->string form))
+ (if (not (or (memq expr '(#t else))
+ (side-effect? test env)))
+ (lint-format "cond last test could be #t: ~A" caller form)))
+ (if (never-true expr)
+ (lint-format "cond test ~A is never true: ~A" caller (car clause) (truncated-list->string form))))
+
+ (unless (side-effect? test env)
+ (if (and (not (memq test '(else #t)))
+ (pair? sequel)
+ (null? (cdr sequel)))
+ (cond ((equal? test (car sequel))
+ (lint-format "no need to repeat the test: ~A" caller (lists->string clause (list test))))
+
+ ((and (pair? (car sequel))
+ (pair? (cdar sequel))
+ (null? (cddar sequel))
+ (equal? test (cadar sequel)))
+ (lint-format "perhaps use => here: ~A" caller
+ (lists->string clause (list test '=> (caar sequel)))))
+
+ ((and (eq? (car sequel) #t)
+ (pair? test)
+ (not (memq (car test) '(or and)))
+ (eq? (return-type (car test) env) 'boolean?))
+ (lint-format "this #t could be omitted: ~A" caller (truncated-list->string clause)))))
+ (if (member test exprs)
+ (lint-format "cond test repeated: ~A" caller (truncated-list->string clause))
+ (set! exprs (cons test exprs))))
+
+ (if (boolean? expr)
+ (if (not expr)
+ (lint-format "cond test is always false: ~A" caller (truncated-list->string clause))
+ (if (not (= ctr len))
+ (lint-format "cond #t clause is not the last: ~A" caller (truncated-list->string form))))
+ (if (eq? test 'else)
+ (if (not (= ctr len))
+ (lint-format "cond else clause is not the last: ~A" caller (truncated-list->string form)))
+ (lint-walk caller test env)))
+
+ (if (and (symbol? expr)
+ (not (var-member expr env))
+ (procedure? (symbol->value expr *e*)))
+ (lint-format "strange cond test: ~A in ~A is a procedure" caller expr clause))
+
+ (if (eq? result :unset)
+ (set! result sequel)
+ (if (not (equal? result sequel))
+ (set! result :unequal)))
+
+ (cond ((not (pair? sequel))
+ (if (not (null? sequel)) ; (not (null?...)) here is correct -- we're looking for stray dots
+ (lint-format "cond clause is messed up: ~A" caller (truncated-list->string clause))))
- (when all-eqv
- (unless eqv-select
- (set! eqv-select (eqv-selector (car clause))))
- (set! all-eqv (and eqv-select
- (not (and (pair? (cdr clause))
- (eq? (cadr clause) '=>))) ; case sends selector, but cond sends test result
- (cond-eqv? (car clause) eqv-select #t))))
+ ((not (eq? (car sequel) '=>))
+ (lint-walk-open-body caller 'cond sequel env))
- (if (and prev-clause
- (not has-combinations)
- (> len 2)
- (equal? (cdr clause) (cdr prev-clause)))
- (if (memq (car clause) '(else #t)) ; (cond ... (x z) (else z)) -> (cond ... (else z))
- (unless (side-effect? (car prev-clause) env)
- (lint-format* caller
- "this clause could be omitted: "
- (truncated-list->string prev-clause)))
- (set! has-combinations #t))) ; handle these later
- (set! prev-clause clause)
+ ((or (not (pair? (cdr sequel)))
+ (pair? (cddr sequel)))
+ (lint-format "cond => target is messed up: ~A" caller (truncated-list->string clause)))
- (let ((expr (simplify-boolean (car clause) trues falses env))
- (test (car clause))
- (sequel (cdr clause)))
- (if (not (equal? expr test))
- (set! simplifications (cons (cons clause expr) simplifications)))
-
- (cond ((memq test '(else #t))
- (set! has-else #t)
-
- (if (and (pair? sequel)
- (eq? (car sequel) #<unspecified>))
- (lint-format "this #<unspecified> is redundant: ~A" caller clause))
-
- (if (and (pair? sequel) ; (cond (a A) (else (cond ...))) -> (cond (a A) ...)
- (pair? (car sequel)) ; similarly for if, when, and unless
- (null? (cdr sequel)))
- (case (caar sequel)
- ((cond)
- (lint-format "else clause could be folded into the outer cond: ~A" caller
- (lists->string form (append (copy form (make-list ctr))
- (cdar sequel)))))
- ((if)
- (let ((if-expr (car sequel)))
- (lint-format "else clause could be folded into the outer cond: ~A" caller
- (lists->string form
- (append (copy form (make-list ctr))
- (if (= (length if-expr) 3)
- (list (cdr if-expr))
- `((,(cadr if-expr) ,@(unbegin (caddr if-expr)))
- (else ,@(unbegin (cadddr if-expr))))))))))
- ((when unless)
- (lint-format "else clause could be folded into the outer cond: ~A" caller
- (lists->string form
- (append (copy form (make-list ctr))
- (if (eq? (caar sequel) 'when)
- `((,(cadar sequel) ,@(cddar sequel)))
- `(((not ,(cadar sequel)) ,@(cddar sequel)))))))))))
- ((and (equal? test ''else)
- (= ctr len))
- (lint-format "odd cond clause test: is 'else supposed to be else? ~A" caller
- (truncated-list->string clause)))
+ (else (let ((f (cadr sequel)))
+ (if (symbol? f)
+ (let ((val (symbol->value f *e*)))
+ (when (procedure? val)
+ (if (not (aritable? val 1)) ; here values might be in test expr
+ (lint-format "=> target (~A) may be unhappy: ~A" caller f clause))
+ (let ((sig (procedure-signature val)))
+ (if (and (pair? sig)
+ (pair? (cdr sig)))
+ (let ((from-type (->lint-type expr))
+ (to-type (cadr sig)))
+ (if (not (or (memq from-type '(#f #t values))
+ (memq to-type '(#f #t values))
+ (any-compatible? to-type from-type)))
+ (lint-format "in ~A, ~A returns a ~A, but ~A expects ~A" caller
+ (truncated-list->string clause)
+ expr (prettify-checker-unq from-type)
+ f to-type)))))))
+ (if (and (pair? f)
+ (eq? (car f) 'lambda)
+ (pair? (cdr f))
+ (pair? (cadr f))
+ (not (= (length (cadr f)) 1)))
+ (lint-format "=> target (~A) may be unhappy: ~A" caller f clause)))
+ (lint-walk caller f env))))
+
+ (if (side-effect? expr env)
+ (begin
+ (set! falses ())
+ (set! trues ())
+ (set! result :unequal))
+ (begin
+ (if (not (member expr falses))
+ (set! falses (cons expr falses)))
+ (if (and (pair? expr)
+ (eq? (car expr) 'not)
+ (not (member (cadr expr) trues)))
+ (set! trues (cons (cadr expr) trues)))
+ (if (and (pair? expr)
+ (eq? (car expr) 'or))
+ (for-each (lambda (p)
+ (if (not (member p falses))
+ (set! falses (cons p falses))))
+ (cdr expr)))))))))
+ (cdr form))) ; for-each clause
+
+ (if has-else
+ (if (pair? result) ; all result clauses are the same (and not implicit)
+ (lint-format "perhaps ~A" caller (lists->string form
+ (if (null? (cdr result))
+ (car result)
+ `(begin , at result)))))
+ (let* ((last-clause (and (> len 1)
+ (list-ref form len)))
+ (clen (and (pair? last-clause)
+ (length last-clause)))
+ (last-res (and (integer? clen)
+ (> clen 1)
+ (list-ref last-clause (- clen 1)))))
+ (if (and (pair? last-res)
+ (memq (car last-res) '(#t else)))
+ (lint-format "perhaps cond else clause is misplaced: ~A in ~A" caller last-res last-clause))))
+
+ (if (and (= len 2)
+ (not (check-bool-cond caller form (cadr form) (caddr form) env))
+ (pair? (cadr form)) ; (cond 1 2)!
+ (pair? (caddr form))
+ (equal? (simplify-boolean (caadr form) () () env)
+ (simplify-boolean `(not ,(caaddr form)) () () env)))
+ (lint-format "perhaps ~A" caller ; (cond ((x) y) ((not (x)) z)) -> (cond ((x) y) (else z))
+ (lists->string form `(cond ,(cadr form) (else ,@(cdaddr form))))))
+
+ (when has-combinations
+ (let ((new-clauses ())
+ (current-clauses ()))
+ (do ((clauses (cdr form) (cdr clauses)))
+ ((null? clauses)
+ (let ((len (length new-clauses)))
+ (if (not (and (= len 2) ; i.e. don't go to check-bool-cond
+ (check-bool-cond caller form (cadr new-clauses) (car new-clauses) env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ form
+ (cond (all-eqv
+ (cond->case eqv-select (reverse new-clauses)))
+ ((not (and (= len 2)
+ (pair? (car new-clauses))
+ (memq (caar new-clauses) '(else #t))
+ (pair? (cadr new-clauses))
+ (pair? (caadr new-clauses))
+ (eq? (caaadr new-clauses) 'or)
+ (null? (cdadr new-clauses))))
+ `(cond ,@(reverse new-clauses)))
+ ((null? (cddar new-clauses)) ; (cond (A) (B) (else C)) -> (or A B C)
+ `(or ,@(cdaadr new-clauses) ,(cadar new-clauses)))
+ (else `(or ,@(cdaadr new-clauses) (begin ,@(cdar new-clauses))))))))
+ (set! simplifications ())
+ (set! all-eqv #f)))
+
+ (let* ((clause (car clauses))
+ (result (cdr clause))) ; can be null in which case the test is the result
+ (cond ((and (pair? simplifications)
+ (assq clause simplifications))
+ => (lambda (e)
+ (set! clause (cons (cdr e) result)))))
+ (if (and (pair? (cdr clauses))
+ (equal? result (cdadr clauses)))
+ (set! current-clauses (cons clause current-clauses))
+ (if (pair? current-clauses)
+ (begin
+ (set! current-clauses (cons clause current-clauses))
+ (set! new-clauses (cons
+ (cons (simplify-boolean `(or ,@(map car (reverse current-clauses))) () () env)
+ result)
+ new-clauses))
+ (set! current-clauses ()))
+ (set! new-clauses (cons clause new-clauses))))))))
+
+ (when (and all-eqv
+ (> len (if has-else 2 1))) ; (cond (x y)) -- kinda dumb, but (if x y) isn't much shorter
+ (lint-format "perhaps use case instead of cond: ~A" caller
+ (lists->string form (cond->case eqv-select (cdr form)))))
+
+ (if (and (= len 2)
+ has-else
+ (null? (cdadr form)))
+ (let ((else-clause (if (null? (cddr (caddr form)))
+ (cadr (caddr form))
+ `(begin ,@(cdr (caddr form))))))
+ (lint-format "perhaps ~A" caller (lists->string form `(or ,(caadr form) ,else-clause)))))
+
+ ;; --------
+ (unless (or has-combinations all-eqv)
+ ;; look for repeated ((op x c1) c2) -> ((assoc x '((c1 . c2)...)) => cdr) anywhere in the clause list
+ (let ((nc ())
+ (op #f)
+ (sym-access #f)
+ (start #f)
+ (changed #f))
+
+ ;; extending this to memx possibilities got only 1 hit and involved ca. 20 lines
+
+ (define (car-with-expr cls)
+ (cond ((and (pair? simplifications)
+ (assq cls simplifications))
+ => (lambda (e)
+ (set! changed #t)
+ (cons (cdr e) (cdr cls))))
+ (else cls)))
+
+ (define (start-search clauses test)
+ (if (code-constant? (cadr test))
+ (if (memq (car test) '(= string=? string-ci=? eq? eqv? equal? char=? char-ci=?))
+ (set! sym-access caddr))
+ (if (code-constant? (caddr test))
+ (set! sym-access cadr)))
+ (if sym-access
+ (begin
+ (set! start clauses)
+ (set! op (car test)))
+ (set! nc (cons (car-with-expr (car clauses)) nc))))
+
+ (do ((clauses (cdr form) (cdr clauses)))
+ ((or (null? clauses)
+ (not (pair? (car clauses))))
+ (if (and changed
+ (null? clauses))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(cond ,@(reverse (map (lambda (c)
+ (if (not (car c)) (values) c))
+ nc)))))))
+ (let* ((test (caar clauses))
+ (result (cdar clauses))
+ (ok-but-at-end #f)
+ (looks-ok (and (pair? test)
+ (pair? (cdr test))
+ (pair? (cddr test))
+ (null? (cdddr test))
+ (pair? result)
+ (null? (cdr result))
+ (not (symbol? (car result)))
+ (or (not (pair? (car result))) ; quoted lists look bad in this context
+ (and (eq? (caar result) 'quote)
+ (not (pair? (cadar result))))))))
+ (if (not start)
+ (if (and looks-ok
+ (not (null? (cdr clauses))))
+ (start-search clauses test)
+ (set! nc (cons (car-with-expr (car clauses)) nc)))
+
+ (when (or (not looks-ok)
+ (not (eq? (car test) op))
+ (not (equal? (sym-access test) (sym-access (caar start))))
+ (not (code-constant? ((if (eq? sym-access cadr) caddr cadr) test)))
+ (set! ok-but-at-end (null? (cdr clauses))))
+
+ (if (eq? (cdr start) clauses) ; only one item in the block, or two but it's just two at the end
+ (begin
+ (set! nc (cons (car start) nc))
+ (if (and looks-ok
+ (not (null? (cdr clauses))))
+ (start-search clauses test)
+ (begin
+ (set! start #f)
+ (set! nc (cons (car-with-expr (car clauses)) nc)))))
+
+ ;; multiple hits -- can we combine them?
+ (let ((alist ())
+ (cc (if (eq? sym-access cadr) caddr cadr)))
+ (set! changed #t)
+ (do ((sc start (cdr sc)))
+ ((if ok-but-at-end
+ (null? sc)
+ (eq? sc clauses))
+ (case op
+ ((eq?)
+ (set! nc (cons `((assq ,(sym-access (caar start)) ',(reverse alist)) => cdr) nc)))
- ((and (eq? test 't)
- (= ctr len)
- (not (var-member 't env)))
- (lint-format "odd cond clause test: is t supposed to be #t? ~A" caller
- (truncated-list->string clause))))
-
- (if (never-false expr)
- (if (not (= ctr len))
- (lint-format "cond test ~A is never false: ~A" caller (car clause) (truncated-list->string form))
- (if (not (or (memq expr '(#t else))
- (side-effect? test env)))
- (lint-format "cond last test could be #t: ~A" caller form)))
- (if (never-true expr)
- (lint-format "cond test ~A is never true: ~A" caller (car clause) (truncated-list->string form))))
-
- (unless (side-effect? test env)
- (if (and (not (memq test '(else #t)))
- (pair? sequel)
- (null? (cdr sequel)))
- (cond ((equal? test (car sequel))
- (lint-format "no need to repeat the test: ~A" caller (lists->string clause (list test))))
-
- ((and (pair? (car sequel))
- (pair? (cdar sequel))
- (null? (cddar sequel))
- (equal? test (cadar sequel)))
- (lint-format "perhaps use => here: ~A" caller
- (lists->string clause (list test '=> (caar sequel)))))
-
- ((and (eq? (car sequel) #t)
- (pair? test)
- (not (memq (car test) '(or and)))
- (eq? (return-type (car test) env) 'boolean?))
- (lint-format "this #t could be omitted: ~A" caller (truncated-list->string clause)))))
- (if (member test exprs)
- (lint-format "cond test repeated: ~A" caller (truncated-list->string clause))
- (set! exprs (cons test exprs))))
-
- (if (boolean? expr)
- (if (not expr)
- (lint-format "cond test is always false: ~A" caller (truncated-list->string clause))
- (if (not (= ctr len))
- (lint-format "cond #t clause is not the last: ~A" caller (truncated-list->string form))))
- (if (eq? test 'else)
- (if (not (= ctr len))
- (lint-format "cond else clause is not the last: ~A" caller (truncated-list->string form)))
- (lint-walk caller test env)))
-
- (if (and (symbol? expr)
- (not (var-member expr env))
- (procedure? (symbol->value expr *e*)))
- (lint-format "strange cond test: ~A in ~A is a procedure" caller expr clause))
-
- (if (eq? result :unset)
- (set! result sequel)
- (if (not (equal? result sequel))
- (set! result :unequal)))
-
- (cond ((not (pair? sequel))
- (if (not (null? sequel)) ; (not (null?...)) here is correct -- we're looking for stray dots
- (lint-format "cond clause is messed up: ~A" caller (truncated-list->string clause))))
+ ((eqv? char=?)
+ (set! nc (cons `((assv ,(sym-access (caar start)) ',(reverse alist)) => cdr) nc)))
- ((not (eq? (car sequel) '=>))
- (lint-walk-open-body caller head sequel env))
+ ((equal?)
+ (set! nc (cons `((assoc ,(sym-access (caar start)) ',(reverse alist)) => cdr) nc)))
- ((or (not (pair? (cdr sequel)))
- (pair? (cddr sequel)))
- (lint-format "cond => target is messed up: ~A" caller (truncated-list->string clause)))
+ ((string=?)
+ ;; this is probably faster than assoc + string=?, but it creates symbols
+ (let ((nlst (map (lambda (c)
+ (cons (string->symbol (car c)) (cdr c)))
+ alist)))
+ (set! nc (cons `((assq (string->symbol ,(sym-access (caar start))) ',(reverse nlst)) => cdr) nc))))
- (else (let ((f (cadr sequel)))
- (if (symbol? f)
- (let ((val (symbol->value f *e*)))
- (when (procedure? val)
- (if (not (aritable? val 1)) ; here values might be in test expr
- (lint-format "=> target (~A) may be unhappy: ~A" caller f clause))
- (let ((sig (procedure-signature val)))
- (if (and (pair? sig)
- (pair? (cdr sig)))
- (let ((from-type (->lint-type expr))
- (to-type (cadr sig)))
- (if (not (or (memq from-type '(#f #t values))
- (memq to-type '(#f #t values))
- (any-compatible? to-type from-type)))
- (lint-format "in ~A, ~A returns a ~A, but ~A expects ~A" caller
- (truncated-list->string clause)
- expr (prettify-checker-unq from-type)
- f to-type)))))))
- (if (and (pair? f)
- (eq? (car f) 'lambda)
- (pair? (cdr f))
- (pair? (cadr f))
- (not (= (length (cadr f)) 1)))
- (lint-format "=> target (~A) may be unhappy: ~A" caller f clause)))
- (lint-walk caller f env))))
-
- (if (side-effect? expr env)
- (begin
- (set! falses ())
- (set! trues ())
- (set! result :unequal))
- (begin
- (if (not (member expr falses))
- (set! falses (cons expr falses)))
- (if (and (pair? expr)
- (eq? (car expr) 'not)
- (not (member (cadr expr) trues)))
- (set! trues (cons (cadr expr) trues)))
- (if (and (pair? expr)
- (eq? (car expr) 'or))
- (for-each (lambda (p)
- (if (not (member p falses))
- (set! falses (cons p falses))))
- (cdr expr)))))))))
- (cdr form))) ; for-each clause
-
- (if has-else
- (if (pair? result) ; all result clauses are the same (and not implicit)
- (lint-format "perhaps ~A" caller (lists->string form
- (if (null? (cdr result))
- (car result)
- `(begin , at result)))))
- (let* ((last-clause (and (> len 1)
- (list-ref form len)))
- (clen (and (pair? last-clause)
- (length last-clause)))
- (last-res (and (number? clen)
- (> clen 1)
- (list-ref last-clause (- clen 1)))))
- (if (and (pair? last-res)
- (memq (car last-res) '(#t else)))
- (lint-format "perhaps cond else clause is misplaced: ~A in ~A" caller last-res last-clause))))
-
- (if (and (= len 2)
- (not (check-bool-cond caller form (cadr form) (caddr form) env))
- (pair? (cadr form)) ; (cond 1 2)!
- (pair? (caddr form))
- (equal? (simplify-boolean (caadr form) () () env)
- (simplify-boolean `(not ,(caaddr form)) () () env)))
- (lint-format "perhaps ~A" caller ; (cond ((x) y) ((not (x)) z)) -> (cond ((x) y) (else z))
- (lists->string form `(cond ,(cadr form) (else ,@(cdaddr form))))))
-
- (when has-combinations
- (let ((new-clauses ())
- (current-clauses ()))
- (do ((clauses (cdr form) (cdr clauses)))
- ((null? clauses)
- (let ((len (length new-clauses)))
- (if (not (and (= len 2) ; i.e. don't go to check-bool-cond
- (check-bool-cond caller form (cadr new-clauses) (car new-clauses) env)))
- (lint-format "perhaps ~A" caller
- (lists->string
- form
- (if all-eqv
- (cond->case eqv-select (reverse new-clauses))
- (if (and (= len 2) ; (cond (A) (B) (else C)) -> (or A B C)
- (pair? (car new-clauses))
- (memq (caar new-clauses) '(else #t))
- (pair? (cadr new-clauses))
- (pair? (caadr new-clauses))
- (eq? (caaadr new-clauses) 'or)
- (null? (cdadr new-clauses)))
- (if (null? (cddar new-clauses))
- `(or ,@(cdaadr new-clauses) ,(cadar new-clauses))
- `(or ,@(cdaadr new-clauses) (begin ,@(cdar new-clauses))))
- `(cond ,@(reverse new-clauses)))))))
- (set! simplifications ())
- (set! all-eqv #f)))
-
- (let* ((clause (car clauses))
- (result (cdr clause))) ; can be null in which case the test is the result
- (cond ((and (pair? simplifications)
- (assq clause simplifications))
- => (lambda (e)
- (set! clause (cons (cdr e) result)))))
- (if (and (pair? (cdr clauses))
- (equal? result (cdadr clauses)))
- (set! current-clauses (cons clause current-clauses))
- (if (pair? current-clauses)
- (begin
- (set! current-clauses (cons clause current-clauses))
- (set! new-clauses (cons
- (cons (simplify-boolean `(or ,@(map car (reverse current-clauses))) () () env)
- result)
- new-clauses))
- (set! current-clauses ()))
- (set! new-clauses (cons clause new-clauses))))))))
-
- (when (and all-eqv
- (> len (if has-else 2 1))) ; (cond (x y)) -- kinda dumb, but (if x y) isn't much shorter
- (lint-format "perhaps use case instead of cond: ~A" caller
- (lists->string form (cond->case eqv-select (cdr form)))))
-
- (if (and (= len 2)
- has-else
- (null? (cdadr form)))
- (let ((else-clause (if (null? (cddr (caddr form)))
- (cadr (caddr form))
- `(begin ,@(cdr (caddr form))))))
- (lint-format "perhaps ~A" caller (lists->string form `(or ,(caadr form) ,else-clause)))))
-
- ;; --------
- (unless (or has-combinations all-eqv)
- ;; look for repeated ((op x c1) c2) -> ((assoc x '((c1 . c2)...)) => cdr) anywhere in the clause list
- (let ((nc ())
- (op #f)
- (c #f)
- (start #f)
- (changed #f))
-
- (define (car-with-expr cls)
- (cond ((and (pair? simplifications)
- (assq cls simplifications))
- => (lambda (e)
- (set! changed #t)
- (cons (cdr e) (cdr cls))))
- (else cls)))
-
- (define (start-search clauses test)
- (if (code-constant? (cadr test))
- (if (memq (car test) '(= string=? string-ci=? eq? eqv? equal? char=? char-ci=?))
- (set! c caddr))
- (if (code-constant? (caddr test))
- (set! c cadr)))
- (if c
- (begin
- (set! start clauses)
- (set! op (car test)))
- (set! nc (cons (car-with-expr (car clauses)) nc))))
-
- (do ((clauses (cdr form) (cdr clauses)))
- ((or (null? clauses)
- (not (pair? (car clauses))))
- (if (and changed
- (null? clauses))
- (lint-format "perhaps ~A" caller
- (lists->string form `(cond ,@(reverse nc))))))
- (let* ((test (caar clauses))
- (result (cdar clauses))
- (ok-but-at-end #f)
- (looks-ok (and (pair? test)
- (pair? (cdr test))
- (pair? (cddr test))
- (null? (cdddr test))
- (pair? result)
- (null? (cdr result))
- (not (symbol? (car result)))
- (or (not (pair? (car result))) ; quoted lists look bad in this context
- (and (eq? (caar result) 'quote)
- (not (pair? (cadar result))))))))
- (if (not start)
+ (else
+ (set! nc (cons `((assoc ,(sym-access (caar start)) ',(reverse alist) ,op) => cdr) nc)))))
+
+ (set! alist (cons (cons (unquoted (cc (caar sc))) (unquoted (cadar sc))) alist)))
+
(if (and looks-ok
(not (null? (cdr clauses))))
(start-search clauses test)
- (set! nc (cons (car-with-expr (car clauses)) nc)))
-
- (when (or (not looks-ok)
- (not (eq? (car test) op))
- (not (equal? (c test) (c (caar start))))
- (not (code-constant? ((if (eq? c cadr) caddr cadr) test)))
- (set! ok-but-at-end (null? (cdr clauses))))
-
- (if (eq? (cdr start) clauses) ; only one item in the block, or two but it's just two at the end
- (begin
- (set! nc (cons (car start) nc))
- (if (and looks-ok
- (not (null? (cdr clauses))))
- (start-search clauses test)
- (begin
- (set! start #f)
- (set! nc (cons (car-with-expr (car clauses)) nc)))))
-
- ;; multiple hits -- can we combine them?
- (let ((alist ())
- (cc (if (eq? c cadr) caddr cadr)))
- (set! changed #t)
- (do ((sc start (cdr sc)))
- ((if ok-but-at-end
- (null? sc)
- (eq? sc clauses))
- (case op
- ((eq?)
- (set! nc (cons `((assq ,(c (caar start)) ',(reverse alist)) => cdr) nc)))
-
- ((eqv? char=?)
- (set! nc (cons `((assv ,(c (caar start)) ',(reverse alist)) => cdr) nc)))
-
- ((equal?)
- (set! nc (cons `((assoc ,(c (caar start)) ',(reverse alist)) => cdr) nc)))
-
- ((string=?)
- ;; this is probably faster than assoc + string=?, but it creates symbols
- (let ((nlst (map (lambda (c)
- (cons (string->symbol (car c)) (cdr c)))
- alist)))
- (set! nc (cons `((assq (string->symbol ,(c (caar start))) ',(reverse nlst)) => cdr) nc))))
-
- (else
- (set! nc (cons `((assoc ,(c (caar start)) ',(reverse alist) ,op) => cdr) nc)))))
-
- (set! alist (cons (cons (unquoted (cc (caar sc))) (unquoted (cadar sc))) alist)))
-
- (if (and looks-ok
- (not (null? (cdr clauses))))
- (start-search clauses test)
- (begin
- (set! start #f)
- (set! nc (cons (car-with-expr (car clauses)) nc))))))))))))
- ;; --------
-
- (when (pair? (cadr form))
- (if (= len 1)
- (let ((clause (cadr form))) ; (cond (a)) -> a, (cond (a b)) -> (if a b) etc
- (if (null? (cdr clause))
- (lint-format "perhaps ~A" caller (lists->string form (car clause)))
- (if (and (not (eq? (cadr clause) '=>))
- (or (pair? (cddr clause))
- (= suggest made-suggestion)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (null? (cddr clause))
- `(if ,(car clause) ,(cadr clause))
- (if (and (pair? (car clause))
- (eq? (caar clause) 'not))
- `(unless ,@(cdar clause) ,@(cdr clause))
- `(when ,(car clause) ,@(cdr clause)))))))))
- (when has-else ; len > 1 here
- (let ((last-clause (list-ref form (- len 1)))) ; not the else branch! -- just before it.
- (when (and (= len 3)
- (equal? (cdadr form) (cdr (list-ref form len)))
- (pair? (cdaddr form))
- (not (eq? (cadr (caddr form)) '=>)))
+ (begin
+ (set! start #f)
+ (set! nc (cons (car-with-expr (car clauses)) nc))))))))))))
+ ;; --------
+
+ (when (pair? (cadr form))
+ (if (= len 1)
+ (let ((clause (cadr form))) ; (cond (a)) -> a, (cond (a b)) -> (if a b) etc
+ (if (null? (cdr clause))
+ (lint-format "perhaps ~A" caller (lists->string form (car clause)))
+ (if (and (not (eq? (cadr clause) '=>))
+ (or (pair? (cddr clause))
+ (= suggest made-suggestion)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cddr clause))
+ `(if ,(car clause) ,(cadr clause))
+ (if (and (pair? (car clause))
+ (eq? (caar clause) 'not))
+ `(unless ,@(cdar clause) ,@(cdr clause))
+ `(when ,(car clause) ,@(cdr clause)))))))))
+ (when has-else ; len > 1 here
+ (let ((last-clause (list-ref form (- len 1)))) ; not the else branch! -- just before it.
+
+ (when (and (= len 3)
+ (equal? (cdadr form) (cdr (list-ref form len))) ; a = else result
+ (pair? (cdaddr form)) ; b does exist
+ (not (eq? (cadr (caddr form)) '=>))) ; no => in b
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((A (caadr form))
+ (a (cdadr form))
+ (B (caaddr form))
+ (b (cdaddr form)))
+ (let ((nexpr (simplify-boolean `(or ,A (not ,B)) () () env)))
+ (cond ((not (and (null? (cdr a))
+ (null? (cdr b))))
+ `(cond (,nexpr , at a) (else , at b)))
+
+ ((eq? (car a) #t)
+ (if (not (car b))
+ nexpr
+ (simplify-boolean `(or ,nexpr ,(car b)) () () env)))
+
+ ((car a) ; i.e a is not #f
+ `(if ,nexpr ,(car a) ,(car b)))
+
+ ((eq? (car b) #t)
+ (simplify-boolean `(not ,nexpr) () () env))
+
+ (else (simplify-boolean `(and (not ,nexpr) ,(car b)) () () env))))))))
+ (when (> len 3)
+ ;; this is not ideal
+ (let ((e (list-ref form len)) ; (cond (W X) (A B) (C D) (else B)) -> (cond (W X) ((or A (not C)) B) (else D))
+ (b (list-ref form (- len 1)))
+ (a (list-ref form (- len 2))))
+ (if (and (pair? a)
+ (pair? (cdr a)) ; is (else) a legal cond clause? -- yes, it returns else...
+ (pair? e)
+ (equal? (cdr a) (cdr e))
+ (pair? b)
+ (pair? (cdr b))
+ (not (eq? (cadr b) '=>)))
+ (let ((expr (simplify-boolean `(or ,(car a) (not ,(car b))) () () env)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(cond ,(if (> len 4) '... (cadr form))
+ (,expr ,@(cdr a))
+ (else ,@(cdr b)))))))))
+
+ (let ((arg1 (cadr form))
+ (arg2 (caddr form)))
+ (if (and (pair? arg1)
+ (pair? arg2)
+ (pair? (car arg1))
+ (eq? (caar arg1) 'and)
+ (pair? (cdr arg1))
+ (null? (cddr arg1))
+ (pair? (cdr arg2))
+ (null? (cddr arg2))
+ (member (car arg2) (cdar arg1))
+ (= (length (cdar arg1)) 2))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond (,(car arg2)
+ (if ,((if (equal? (car arg2) (cadar arg1)) caddar cadar) arg1)
+ ,(cadr arg1)
+ ,(cadr arg2)))
+ ,@(cdddr form)))))
+
+ (if (and (= len 2) ; (cond ((not A) B) (else C)) -> (if A C B)
+ (pair? arg1)
+ (pair? (car arg1))
+ (eq? (caar arg1) 'not)
+ (pair? (cdr arg2))
+ (> (tree-leaves (cdr arg1)) (tree-leaves (cdr arg2))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (and (null? (cddr arg1))
+ (null? (cddr arg2)))
+ `(if ,(cadar arg1) ,(cadr arg2) ,(cadr arg1))
+ `(cond (,(cadar arg1) ,@(cdr arg2)) (else ,@(cdr arg1))))))))
+
+ (if (and (pair? last-clause) ; (cond ... ((or ...)) (else ...)) -> (cond ... (else (or ... ...)))
+ (pair? (car last-clause))
+ (null? (cdr last-clause))
+ (eq? (caar last-clause) 'or))
+ (let* ((e (list-ref form len))
+ (else-clause (if (null? (cddr e))
+ (cadr e)
+ `(begin ,@(cdr e)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond ,@(copy (cdr form) (make-list (- len 2)))
+ (else (or ,@(cdar last-clause) ,else-clause))))))))))
+
+ (let ((last-clause (list-ref form (if has-else (- len 1) len)))) ; not the else branch! -- just before it.
+ (if (and (pair? last-clause) ; (cond ... (A (cond ...)) (else B)) -> (cond ... ((not A) B) ...)
+ (pair? (cdr last-clause))
+ (null? (cddr last-clause))
+ (pair? (cadr last-clause))
+ (memq (caadr last-clause) '(if cond)))
+ (let ((new-test (simplify-boolean `(not ,(car last-clause)) () () env))
+ (new-result (if has-else
+ (cdr (list-ref form len))
+ (if (eq? form lint-mid-form)
+ ()
+ (list #<unspecified>)))))
+ (if (eq? (caadr last-clause) 'cond)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(cond ,@(copy (cdr form) (make-list (- len (if has-else 2 1))))
+ (,new-test , at new-result)
+ ,@(cdadr last-clause))))
+ (if (= (length (cadr last-clause)) 4)
+ (let ((if-form (cadr last-clause)))
(lint-format "perhaps ~A" caller
(lists->string form
- (let ((A (caadr form))
- (a (cdadr form))
- (B (caaddr form))
- (b (cdaddr form)))
- (let ((nexpr (simplify-boolean `(or ,A (not ,B)) () () env)))
- (cond ((not (and (null? (cdr a))
- (null? (cdr b))))
- `(cond (,nexpr , at a) (else , at b)))
-
- ((eq? (car a) #t)
- (if (not (car b))
- nexpr
- (simplify-boolean `(or ,nexpr ,(car b)) () () env)))
-
- ((car a)
- `(if ,nexpr ,(car a) ,(car b)))
-
- ((eq? (car b) #t)
- (simplify-boolean `(not ,nexpr) () () env))
-
- (else (simplify-boolean `(and (not ,nexpr) ,(car b)) () () env))))))))
- (let ((arg1 (cadr form))
- (arg2 (caddr form)))
- (if (and (pair? arg1)
- (pair? arg2)
- (pair? (car arg1))
- (eq? (caar arg1) 'and)
- (pair? (cdr arg1))
- (null? (cddr arg1))
- (pair? (cdr arg2))
- (null? (cddr arg2))
- (member (car arg2) (cdar arg1))
- (= (length (cdar arg1)) 2))
+ `(cond ,@(copy (cdr form) (make-list (- len (if has-else 2 1))))
+ (,new-test , at new-result)
+ (,(cadr if-form) ,@(unbegin (caddr if-form)))
+ (else ,@(unbegin (cadddr if-form))))))))))
+ (when (> len 2) ; rewrite nested conds as one cond
+ (let ((lim (if has-else (- len 2) len))
+ (tlen (tree-leaves form)))
+ (when (< tlen 200)
+ (set! tlen (/ tlen 4))
+ (do ((i 0 (+ i 1))
+ (k (+ lim 1) (- k 1))
+ (p (cdr form) (cdr p)))
+ ((or (not (pair? p))
+ (= i lim)))
+ (let ((nc (car p)))
+ (if (and (pair? nc)
+ (pair? (cdr nc))
+ (null? (cddr nc))
+ (pair? (cadr nc))
+ (eq? (caadr nc) 'cond)
+ (>= (length (cdadr nc)) (* 2 k))
+ (> (tree-leaves nc) tlen))
+ (let ((new-test (simplify-boolean `(not ,(car nc)) () () env))
+ (new-result (if (and has-else
+ (= i (- lim 1))
+ (null? (cddadr p))
+ (null? (cddr (caddr p))))
+ `(if ,(caadr p) ,(cadadr p) ,(cadr (caddr p)))
+ `(cond ,@(cdr p)))))
(lint-format "perhaps ~A" caller
(lists->string form
- `(cond (,(car arg2)
- (if ,(if (equal? (car arg2) (cadar arg1)) (caddar arg1) (cadar arg1))
- ,(cadr arg1)
- ,(cadr arg2)))
- ,@(cdddr form)))))
-
- (if (and (= len 2) ; (cond ((not A) B) (else C)) -> (if A C B)
- (pair? arg1)
- (pair? (car arg1))
- (eq? (caar arg1) 'not)
- (pair? (cdr arg2))
- (> (tree-leaves (cdr arg1)) (tree-leaves (cdr arg2))))
+ `(cond ,@(copy (cdr form) (make-list i))
+ (,new-test ,new-result)
+ ,@(cdadr nc))))))))))))))))
+ env))
+ (hash-table-set! h 'cond cond-walker))
+
+ ;; ---------------- case ----------------
+ (let ((selector-types '(#t symbol? char? boolean? integer? rational? real? complex? number? null? eof-object?)))
+ (define (case-walker caller form env)
+ ;; here the keys are not evaluated, so we might have a list like (letrec define ...)
+ ;; also unlike cond, only 'else marks a default branch (not #t)
+
+ (if (< (length form) 3)
+ (lint-format "case is messed up: ~A" caller (truncated-list->string form))
+ (let ((sel-type #t)
+ (selector (cadr form))
+ (suggest made-suggestion))
+
+ ;; ----------------
+ ;; if regular case + else -- just like cond above
+ (let ((len (- (length form) 2))) ; number of clauses
+ (when (and (> len 1) ; (case x (else ...)) is handled elsewhere
+ (pair? (cdr form))
+ (pair? (cddr form))
+ (pair? (caddr form))
+ (not (tree-set-member '(unquote #_{list}) form)))
+ (let ((first-clause (caddr form))
+ (else-clause (list-ref form (+ len 1))))
+
+ (when (and (pair? else-clause)
+ (eq? (car else-clause) 'else)
+ (pair? (cdr first-clause))
+ (pair? (cadr first-clause))
+ (not (hash-table-ref syntaces (caadr first-clause)))
+ (pair? (cdadr first-clause))
+ (null? (cddr first-clause))
+ (every? (lambda (c)
+ (and (pair? c)
+ (pair? (cdr c))
+ (pair? (cadr c))
+ (null? (cddr c))
+ (not (hash-table-ref syntaces (caadr c)))
+ (equal? (cdadr first-clause) (cdadr c))))
+ (cdddr form)))
+ (lint-format "perhaps ~A" caller ; all results share trailing args
+ (lists->string form
+ (if (and (= len 2)
+ (symbol? (caar first-clause))
+ (null? (cdar first-clause)))
+ `((if (eq? ,(cadr form) ',(caar first-clause))
+ ,(caadr first-clause)
+ ,(caadr else-clause))
+ ,@(cdadr first-clause))
+ `((case ,(cadr form)
+ ,@(map (lambda (c)
+ (list (car c) (caadr c)))
+ (cddr form)))
+ ,@(cdadr first-clause))))))
+
+ (when (and (pair? (cdr first-clause))
+ (null? (cddr first-clause))
+ (pair? (cadr first-clause))
+ (pair? else-clause)
+ (eq? (car else-clause) 'else)
+ (pair? (cdr else-clause))
+ (pair? (cadr else-clause))
+ (or (equal? (caadr first-clause) (caadr else-clause)) ; there's some hope we'll match
+ (escape? (cadr else-clause) env)))
+ (let ((first-result (cadr first-clause))
+ (first-func (caadr first-clause))
+ (else-error (escape? (cadr else-clause) env)))
+ (when (and (pair? (cdr first-result))
+ (not (eq? first-func 'values))
+ (or (not (hash-table-ref syntaces first-func))
+ (eq? first-func 'set!))
+ (every? (lambda (c)
+ (and (pair? c)
+ (pair? (cdr c))
+ (pair? (cadr c))
+ (null? (cddr c))
+ (pair? (cdadr c))
+ (or (equal? first-func (caadr c))
+ (and (eq? c else-clause)
+ else-error))))
+ (cdddr form)))
+
+ ((lambda (header-len trailer-len result-mid-len)
+ (when (and (or (not (eq? first-func 'set!))
+ (> header-len 1))
+ (or (not (eq? first-func '/))
+ (> header-len 1)
+ (> trailer-len 0)))
+ (let ((header (copy first-result (make-list header-len)))
+ (trailer (copy first-result (make-list trailer-len) (- (length first-result) trailer-len))))
+ (if (= len 2)
+ (unless (equal? first-result (cadr else-clause)) ; handled elsewhere (all results equal -> result)
(lint-format "perhaps ~A" caller
- (lists->string form
- (if (and (null? (cddr arg1))
- (null? (cddr arg2)))
- `(if ,(cadar arg1) ,(cadr arg2) ,(cadr arg1))
- `(cond (,(cadar arg1) ,@(cdr arg2)) (else ,@(cdr arg1))))))))
-
-
- (if (and (pair? last-clause) ; (cond ... ((or ...)) (else ...)) -> (cond ... (else (or ... ...)))
- (pair? (car last-clause))
- (null? (cdr last-clause))
- (eq? (caar last-clause) 'or))
- (let* ((e (list-ref form len))
- (else-clause (if (null? (cddr e))
- (cadr e)
- `(begin ,@(cdr e)))))
+ (let ((else-result (cadr else-clause)))
+ (let ((first-mid-len (- (length first-result) header-len trailer-len))
+ (else-mid-len (- (length else-result) header-len trailer-len)))
+ (let* ((fmid (if (= first-mid-len 1)
+ (list-ref first-result header-len)
+ `(values ,@(copy first-result (make-list first-mid-len) header-len))))
+ (emid (if else-error
+ else-result
+ (if (= else-mid-len 1)
+ (list-ref else-result header-len)
+ `(values ,@(copy else-result (make-list else-mid-len) header-len)))))
+ (middle (if (= (length (car first-clause)) 1)
+ `(eqv? ,(cadr form) ,(caar first-clause))
+ `(memv ,(cadr form) ',(car first-clause)))))
+ (lists->string form `(, at header (if ,middle ,fmid ,emid) , at trailer)))))))
+ ;; len > 2 so use case in the revision
+ (let ((middle (map (lambda (c)
+ (let ((test (car c))
+ (result (cadr c)))
+ (let ((mid-len (- (length result) header-len trailer-len)))
+ (if (and else-error
+ (eq? c else-clause))
+ else-clause
+ `(,test ,(if (= mid-len 1)
+ (list-ref result header-len)
+ `(values ,@(copy result (make-list mid-len) header-len))))))))
+ (cddr form))))
(lint-format "perhaps ~A" caller
- (lists->string form
- `(cond ,@(copy (cdr form) (make-list (- len 2)))
-
- (else (or ,@(cdar last-clause) ,else-clause))))))))))
-
- (let ((last-clause (list-ref form (if has-else (- len 1) len)))) ; not the else branch! -- just before it.
- (if (and (pair? last-clause) ; (cond ... (A (cond ...)) (else B)) -> (cond ... ((not A) B) ...)
- (pair? (cdr last-clause))
- (null? (cddr last-clause))
- (pair? (cadr last-clause))
- (memq (caadr last-clause) '(if cond)))
- (let ((new-test (simplify-boolean `(not ,(car last-clause)) () () env))
- (new-result (if has-else
- (cdr (list-ref form len))
- (if (eq? form lint-mid-form)
- ()
- (list #<unspecified>)))))
- (if (eq? (caadr last-clause) 'cond)
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(cond ,@(copy (cdr form) (make-list (- len (if has-else 2 1))))
- (,new-test , at new-result)
- ,@(cdadr last-clause))))
- (if (= (length (cadr last-clause)) 4)
- (let ((if-form (cadr last-clause)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(cond ,@(copy (cdr form) (make-list (- len (if has-else 2 1))))
- (,new-test , at new-result)
- (,(cadr if-form) ,@(unbegin (caddr if-form)))
- (else ,@(unbegin (cadddr if-form))))))))))
- (when (> len 2) ; rewrite nested conds as one cond
- (let ((lim (if has-else (- len 2) len))
- (tlen (tree-leaves form)))
- (when (< tlen 200)
- (set! tlen (/ tlen 4))
- (do ((i 0 (+ i 1))
- (k (+ lim 1) (- k 1))
- (p (cdr form) (cdr p)))
- ((or (not (pair? p))
- (= i lim)))
- (let ((nc (car p)))
- (if (and (pair? nc)
- (pair? (cdr nc))
- (null? (cddr nc))
- (pair? (cadr nc))
- (eq? (caadr nc) 'cond)
- (>= (length (cdadr nc)) (* 2 k))
- (> (tree-leaves nc) tlen))
- (let ((new-test (simplify-boolean `(not ,(car nc)) () () env))
- (new-result (if (and has-else
- (= i (- lim 1))
- (null? (cddadr p))
- (null? (cddr (caddr p))))
- `(if ,(caadr p) ,(cadadr p) ,(cadr (caddr p)))
- `(cond ,@(cdr p)))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(cond ,@(copy (cdr form) (make-list i))
- (,new-test ,new-result)
- ,@(cdadr nc))))))))))))))))
- env))
+ (lists->string form `(, at header (case ,(cadr form) , at middle) , at trailer))))))))
+ (partition-form (cddr form) (if else-error (- len 1) len)))))))))
+ ;; ----------------
+
+ (when (= suggest made-suggestion)
+ (let ((clauses (cddr form))) ; (case x ((a) #t) (else #f)) -> (eq? x 'a) -- this stuff actually happens!
+ (if (null? (cdr clauses))
+ (let ((clause (car clauses)))
+ (when (and (pair? clause)
+ (pair? (car clause))
+ (pair? (cdr clause)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((test (cond ((pair? (cdar clause))
+ `(memv ,(cadr form) ',(car clause)))
+ ((and (symbol? (caar clause))
+ (not (keyword? (caar clause))))
+ `(eq? ,(cadr form) ',(caar clause)))
+ ((or (keyword? (caar clause))
+ (null? (caar clause)))
+ `(eq? ,(cadr form) ,(caar clause)))
+ ((not (boolean? (caar clause)))
+ `(eqv? ,(cadr form) ,(caar clause)))
+ ((caar clause)
+ (cadr form))
+ (else `(not ,(cadr form)))))
+ (op (if (and (pair? (cdr clause))
+ (pair? (cddr clause)))
+ 'when 'if)))
+ `(,op ,test ,@(cdr clause)))))))
+ (when (and (null? (cddr clauses))
+ (pair? (car clauses))
+ (pair? (cadr clauses))
+ (eq? (caadr clauses) 'else)
+ (pair? (cdar clauses))
+ (pair? (cdadr clauses))
+ (null? (cddar clauses))
+ (null? (cddadr clauses))
+ (not (equal? (cadadr clauses) (cadar clauses))))
+ (let* ((akey (null? (cdaar clauses)))
+ (keylist ((if akey caaar caar) clauses))
+ (quoted (or (not akey) (symbol? keylist)))
+ (op (if (every? symbol? (caar clauses))
+ (if akey 'eq? 'memq)
+ (if akey 'eqv? 'memv))))
+ ;; can't use '= or 'char=? here because the selector may return anything
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (cond ((and (boolean? (cadar clauses))
+ (boolean? (cadadr clauses)))
+ (if (cadadr clauses)
+ (if quoted
+ `(not (,op ,selector ',keylist))
+ `(not (,op ,selector ,keylist)))
+ (if quoted
+ `(,op ,selector ',keylist)
+ `(,op ,selector ,keylist))))
+
+ ((not (cadadr clauses)) ; (else #f) happens a few times
+ (simplify-boolean
+ (if quoted
+ `(and (,op ,selector ',keylist) ,(cadar clauses))
+ `(and (,op ,selector ,keylist) ,(cadar clauses)))
+ () () env))
+
+ (quoted
+ `(if (,op ,selector ',keylist) ,(cadar clauses) ,(cadadr clauses)))
+
+ (else
+ `(if (,op ,selector ,keylist) ,(cadar clauses) ,(cadadr clauses)))))))))))
+
+ (if (and (not (pair? selector))
+ (constant? selector))
+ (lint-format "case selector is a constant: ~A" caller (truncated-list->string form)))
+ (if (symbol? selector)
+ (set-ref selector caller form env)
+ (lint-walk caller selector env))
+ (if (and (pair? selector)
+ (symbol? (car selector)))
+ (begin
+ (set! sel-type (return-type (car selector) env))
+ (if (and (symbol? sel-type)
+ (not (memq sel-type selector-types)))
+ (lint-format "case selector may not work with eqv: ~A" caller (truncated-list->string selector)))))
- ;; ---------------- case ----------------
- ((case)
- ;; here the keys are not evaluated, so we might have a list like (letrec define ...)
- ;; also unlike cond, only 'else marks a default branch (not #t)
+ (let ((all-keys ())
+ (all-exprs ())
+ (ctr 0)
+ (result :unset)
+ (exprs-repeated #f)
+ (else-foldable #f)
+ (has-else #f)
+ (len (length (cddr form))))
+ (for-each
+ (lambda (clause)
+ (set! ctr (+ ctr 1))
+ (if (not (pair? clause))
+ (lint-format "case clause should be a list: ~A" caller (truncated-list->string clause))
+ (let ((keys (car clause))
+ (exprs (cdr clause)))
+ (if (null? exprs)
+ (lint-format "clause result is missing: ~A" caller clause))
+ (if (eq? result :unset)
+ (set! result exprs)
+ (if (not (equal? result exprs))
+ (set! result :unequal)))
+ (if (member exprs all-exprs)
+ (set! exprs-repeated exprs)
+ (set! all-exprs (cons exprs all-exprs)))
+ (if (and (pair? exprs)
+ (null? (cdr exprs))
+ (pair? (car exprs))
+ (pair? (cdar exprs))
+ (null? (cddar exprs))
+ (equal? selector (cadar exprs)))
+ (lint-format "perhaps use => here: ~A" caller
+ (lists->string clause (list keys '=> (caar exprs)))))
+ (if (pair? keys)
+ (if (not (proper-list? keys))
+ (lint-format (if (null? keys)
+ "null case key list: ~A"
+ "stray dot in case case key list: ~A")
+ caller (truncated-list->string clause))
+ (for-each
+ (lambda (key)
+ (if (or (vector? key)
+ (string? key)
+ (pair? key)
+ (hash-table? key))
+ (lint-format "case key ~S in ~S is unlikely to work (case uses eqv?)" caller key clause))
+ (if (member key all-keys)
+ (lint-format "repeated case key ~S in ~S" caller key clause)
+ (set! all-keys (cons key all-keys)))
+ ;; unintentional quote here, as in (case x ('a b)...) never happens and
+ ;; is hard to distinguish from (case x ((quote a) b)...) which happens a lot
+ (if (not (compatible? sel-type (->lint-type key)))
+ (lint-format "case key ~S in ~S is pointless" caller key clause)))
+ keys))
+ (if (not (eq? keys 'else))
+ (lint-format "bad case key ~S in ~S" caller keys clause)
+ (begin
+ (set! has-else clause)
+ ;; exprs: (res) or if case, ((case ...)...)
+ (if (not (= ctr len))
+ (lint-format "case else clause is not the last: ~A"
+ caller
+ (truncated-list->string (cddr form)))
+ (when (and (pair? exprs)
+ (pair? (car exprs))
+ (null? (cdr exprs)))
+ (case (caar exprs)
+ ((case) ; just the case statement in the else clause
+ (when (and (equal? selector (cadar exprs))
+ (not (side-effect? selector env)))
+ (set! else-foldable (cddar exprs))))
+ ((if) ; just if -- if foldable, make it look like it came from case
+ (when (and (equal? selector (eqv-selector (cadar exprs)))
+ (cond-eqv? (cadar exprs) selector #t)
+ (not (side-effect? selector env)))
+ ;; else-foldable as (((keys-from-test) true-branch) (else false-branch))
+ (set! else-foldable
+ (if (pair? (cdddar exprs))
+ `(,(case-branch (cadar exprs) selector (list (caddar exprs)))
+ (else ,(car (cdddar exprs))))
+ (list (case-branch (cadar exprs) selector (cddar exprs)))))))))))))
+
+ (lint-walk-open-body caller (car form) exprs env))))
+ (cddr form))
+
+ (if (and has-else
+ (pair? result)
+ (not else-foldable))
+ (begin
+ (lint-format "perhaps ~A" caller (lists->string form
+ (if (null? (cdr result))
+ (car result)
+ `(begin , at result))))
+ (set! exprs-repeated #f)))
+
+ (when (or exprs-repeated else-foldable)
+ (let ((new-keys-and-exprs ())
+ (mergers ())
+ (else-clause (if else-foldable
+ (call-with-exit
+ (lambda (return)
+ (for-each (lambda (c) (if (eq? (car c) 'else) (return c))) else-foldable)
+ ()))
+ (or has-else ()))))
+
+ (let ((merge-case-keys
+ (let ((else-exprs (and (pair? else-clause) (cdr else-clause))))
+ (define (a-few lst)
+ (if (> (length lst) 3)
+ (copy lst (make-list 4 '...) 0 3)
+ lst))
+ (lambda (clause)
+ (let ((keys (car clause))
+ (exprs (cdr clause)))
+ (when (and (pair? exprs) ; ignore clauses that are messed up
+ (not (eq? keys 'else))
+ (not (equal? exprs else-exprs)))
+ (let ((prev (member exprs new-keys-and-exprs (lambda (a b) (equal? a (cdr b))))))
+ (if prev
+ (let* ((cur-clause (car prev))
+ (cur-keys (car cur-clause)))
+ (when (pair? cur-keys)
+ (set! mergers (cons (list (a-few keys) (a-few cur-keys)) mergers))
+ (set-car! cur-clause
+ (append cur-keys
+ (map (lambda (key)
+ (if (memv key cur-keys) (values) key))
+ keys)))))
+ (set! new-keys-and-exprs (cons (cons (copy (car clause)) (cdr clause)) new-keys-and-exprs))))))))))
+
+ (for-each merge-case-keys (cddr form))
+ (if (pair? else-foldable)
+ (for-each merge-case-keys else-foldable)))
+
+ (if (null? new-keys-and-exprs)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (or (null? else-clause) ; can this happen? (it's caught above as an error)
+ (null? (cdr else-clause)))
+ ()
+ (if (null? (cddr else-clause))
+ (cadr else-clause)
+ `(begin ,@(cdr else-clause))))))
+ (begin
+ ;; (null? (cdr new-keys-and-exprs)) is rare and kinda dumb -- cases look like test suite entries
+ (for-each
+ (lambda (clause)
+ (if (and (pair? (car clause))
+ (pair? (cdar clause)))
+ (if (every? integer? (car clause))
+ (set-car! clause (sort! (car clause) <))
+ (if (every? char? (car clause))
+ (set-car! clause (sort! (car clause) char<?))))))
+ new-keys-and-exprs)
+ (let ((new-form (if (pair? else-clause)
+ `(case ,(cadr form) ,@(reverse new-keys-and-exprs) ,else-clause)
+ `(case ,(cadr form) ,@(reverse new-keys-and-exprs)))))
+ (lint-format "perhaps ~A" caller
+ (if (pair? mergers)
+ (format #f "merge keys ~{~{~A with ~A~}~^, ~}: ~A"
+ (reverse mergers)
+ (lists->string form new-form))
+ (lists->string form new-form)))))))))))
+ env)
+ (hash-table-set! h 'case case-walker))
+
+
+ ;; ---------------- do ----------------
+ (let ()
+ (define (do-walker caller form env)
+ (let ((vars ()))
+ (if (not (and (>= (length form) 3)
+ (proper-list? (cadr form))
+ (proper-list? (caddr form))))
+ (lint-format "do is messed up: ~A" caller (truncated-list->string form))
+
+ (let ((step-vars (cadr form))
+ (inner-env #f))
+ (define (var-step v) ((cdr v) 'step))
+ ;; do+lambda in body with stepper as free var never happens
- (if (< (length form) 3)
- (lint-format "case is messed up: ~A" caller (truncated-list->string form))
- (let ((sel-type #t)
- (selector (cadr form))
- (suggest made-suggestion))
-
- ;; ----------------
- ;; if regular case + else -- just like cond above
- (let ((len (- (length form) 2))) ; number of clauses
- (when (and (> len 1) ; (case x (else ...)) is handled elsewhere
- (pair? (cdr form))
- (pair? (cddr form))
- (pair? (caddr form))
- (not (tree-set-member '(unquote #_{list}) form)))
- (let ((first-clause (caddr form))
- (else-clause (list-ref form (+ len 1))))
- (when (and (pair? (cdr first-clause))
- (null? (cddr first-clause))
- (pair? (cadr first-clause))
- (pair? else-clause)
- (eq? (car else-clause) 'else)
- (pair? (cdr else-clause))
- (pair? (cadr else-clause))
- (or (equal? (caadr first-clause) (caadr else-clause)) ; there's some hope we'll match
- (escape? (cadr else-clause) env)))
- (let ((first-result (cadr first-clause))
- (first-func (caadr first-clause))
- (else-error (escape? (cadr else-clause) env)))
- (when (and (pair? (cdr first-result))
- (not (eq? first-func 'values))
- (or (not (hash-table-ref syntaces first-func))
- (eq? first-func 'set!))
- (every? (lambda (c)
- (and (pair? c)
- (pair? (cdr c))
- (pair? (cadr c))
- (null? (cddr c))
- (pair? (cdadr c))
- (or (equal? first-func (caadr c))
- (and (eq? c else-clause)
- else-error))))
- (cdddr form)))
-
- ((lambda (header-len trailer-len result-mid-len)
- (when (and (or (not (eq? first-func 'set!))
- (> header-len 1))
- (or (not (eq? first-func '/))
- (> header-len 1)
- (> trailer-len 0)))
- (let ((header (copy first-result (make-list header-len)))
- (trailer (copy first-result (make-list trailer-len) (- (length first-result) trailer-len))))
- (if (= len 2)
- (unless (equal? first-result (cadr else-clause)) ; handled elsewhere (all results equal -> result)
- (lint-format "perhaps ~A" caller
- (let ((else-result (cadr else-clause)))
- (let ((first-mid-len (- (length first-result) header-len trailer-len))
- (else-mid-len (- (length else-result) header-len trailer-len)))
- (let* ((fmid (if (= first-mid-len 1)
- (list-ref first-result header-len)
- `(values ,@(copy first-result (make-list first-mid-len) header-len))))
- (emid (if else-error
- else-result
- (if (= else-mid-len 1)
- (list-ref else-result header-len)
- `(values ,@(copy else-result (make-list else-mid-len) header-len)))))
- (middle (if (= (length (car first-clause)) 1)
- `(eqv? ,(cadr form) ,(caar first-clause))
- `(memv ,(cadr form) ',(car first-clause)))))
- (lists->string form `(, at header (if ,middle ,fmid ,emid) , at trailer)))))))
- ;; len > 2 so use case in the revision
- (let ((middle (map (lambda (c)
- (let ((test (car c))
- (result (cadr c)))
- (let ((mid-len (- (length result) header-len trailer-len)))
- (if (and else-error
- (eq? c else-clause))
- else-clause
- `(,test ,(if (= mid-len 1)
- (list-ref result header-len)
- `(values ,@(copy result (make-list mid-len) header-len))))))))
- (cddr form))))
- (lint-format "perhaps ~A" caller
- (lists->string form `(, at header (case ,(cadr form) , at middle) , at trailer))))))))
- (partition-form (cddr form) (if else-error (- len 1) len)))))))))
- ;; ----------------
-
- (when (= suggest made-suggestion)
- (let ((clauses (cddr form))) ; (case x ((a) #t) (else #f)) -> (eq? x 'a) -- this stuff actually happens!
- (if (null? (cdr clauses))
- (let ((clause (car clauses)))
- (when (and (pair? clause)
- (pair? (car clause))
- (pair? (cdr clause)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (let ((test (cond ((pair? (cdar clause))
- `(memv ,(cadr form) ',(car clause)))
- ((and (symbol? (caar clause))
- (not (keyword? (caar clause))))
- `(eq? ,(cadr form) ',(caar clause)))
- ((or (keyword? (caar clause))
- (null? (caar clause)))
- `(eq? ,(cadr form) ,(caar clause)))
- ((not (boolean? (caar clause)))
- `(eqv? ,(cadr form) ,(caar clause)))
- ((caar clause)
- (cadr form))
- (else `(not ,(cadr form)))))
- (op (if (and (pair? (cdr clause))
- (pair? (cddr clause)))
- 'when 'if)))
- `(,op ,test ,@(cdr clause)))))))
- (when (and (null? (cddr clauses))
- (pair? (car clauses))
- (pair? (cadr clauses))
- (eq? (caadr clauses) 'else)
- (pair? (cdar clauses))
- (pair? (cdadr clauses))
- (null? (cddar clauses))
- (null? (cddadr clauses))
- (not (equal? (cadadr clauses) (cadar clauses))))
- (let* ((akey (null? (cdaar clauses)))
- (keylist (if akey (caaar clauses) (caar clauses)))
- (quoted (or (not akey) (symbol? keylist)))
- (op (if (every? symbol? (caar clauses))
- (if akey 'eq? 'memq)
- (if akey 'eqv? 'memv))))
- ;; can't use '= or 'char=? here because the selector may return anything
- (lint-format "perhaps ~A" caller
- (lists->string form
- (cond ((and (memq (cadar clauses) '(#f #t))
- (memq (cadadr clauses) '(#f #t)))
- (if (cadadr clauses)
- (if quoted
- `(not (,op ,selector ',keylist))
- `(not (,op ,selector ,keylist)))
- (if quoted
- `(,op ,selector ',keylist)
- `(,op ,selector ,keylist))))
- ((not (cadadr clauses)) ; (else #f) happens a few times
- (simplify-boolean
- (if quoted
- `(and (,op ,selector ',keylist) ,(cadar clauses))
- `(and (,op ,selector ,keylist) ,(cadar clauses)))
- () () env))
- (quoted
- `(if (,op ,selector ',keylist) ,(cadar clauses) ,(cadadr clauses)))
- (else `(if (,op ,selector ,keylist) ,(cadar clauses) ,(cadadr clauses)))))))))))
-
- (if (and (not (pair? selector))
- (constant? selector))
- (lint-format "case selector is a constant: ~A" caller (truncated-list->string form)))
- (if (symbol? selector)
- (set-ref selector caller form env)
- (lint-walk caller selector env))
- (if (and (pair? selector)
- (symbol? (car selector)))
- (begin
- (set! sel-type (return-type (car selector) env))
- (if (and (symbol? sel-type)
- (not (memq sel-type selector-types)))
- (lint-format "case selector may not work with eqv: ~A" caller (truncated-list->string selector)))))
-
- (let ((all-keys ())
- (all-exprs ())
- (ctr 0)
- (result :unset)
- (exprs-repeated #f)
- (else-foldable #f)
- (has-else #f)
- (len (length (cddr form))))
- (for-each
- (lambda (clause)
- (set! ctr (+ ctr 1))
- (if (not (pair? clause))
- (lint-format "case clause should be a list: ~A" caller (truncated-list->string clause))
- (let ((keys (car clause))
- (exprs (cdr clause)))
- (if (null? exprs)
- (lint-format "clause result is missing: ~A" caller clause))
- (if (eq? result :unset)
- (set! result exprs)
- (if (not (equal? result exprs))
- (set! result :unequal)))
- (if (member exprs all-exprs)
- (set! exprs-repeated exprs)
- (set! all-exprs (cons exprs all-exprs)))
- (if (and (pair? exprs)
- (null? (cdr exprs))
- (pair? (car exprs))
- (pair? (cdar exprs))
- (null? (cddar exprs))
- (equal? selector (cadar exprs)))
- (lint-format "perhaps use => here: ~A" caller
- (lists->string clause (list keys '=> (caar exprs)))))
- (if (pair? keys)
- (if (not (proper-list? keys))
- (lint-format (if (null? keys)
- "null case key list: ~A"
- "stray dot in case case key list: ~A")
- caller (truncated-list->string clause))
- (for-each
- (lambda (key)
- (if (or (vector? key)
- (string? key)
- (pair? key)
- (hash-table? key))
- (lint-format "case key ~S in ~S is unlikely to work (case uses eqv?)" caller key clause))
- (if (member key all-keys)
- (lint-format "repeated case key ~S in ~S" caller key clause)
- (set! all-keys (cons key all-keys)))
- ;; unintentional quote here, as in (case x ('a b)...) never happens and
- ;; is hard to distinguish from (case x ((quote a) b)...) which happens a lot
- (if (not (compatible? sel-type (->lint-type key)))
- (lint-format "case key ~S in ~S is pointless" caller key clause)))
- keys))
- (if (not (eq? keys 'else))
- (lint-format "bad case key ~S in ~S" caller keys clause)
- (begin
- (set! has-else clause)
- ;; exprs: (res) or if case, ((case ...)...)
- (if (not (= ctr len))
- (lint-format "case else clause is not the last: ~A"
- caller
- (truncated-list->string (cddr form)))
- (and (pair? exprs)
- (pair? (car exprs))
- (null? (cdr exprs))
- (case (caar exprs)
- ((case) ; just the case statement in the else clause
- (and (equal? selector (cadar exprs))
- (not (side-effect? selector env))
- (set! else-foldable (cddar exprs))))
- ((if) ; just if -- if foldable, make it look like it came from case
- (and (equal? selector (eqv-selector (cadar exprs)))
- (cond-eqv? (cadar exprs) selector #t)
- (not (side-effect? selector env))
- ;; else-foldable as (((keys-from-test) true-branch) (else false-branch))
- (set! else-foldable
- (if (pair? (cdddar exprs))
- `(,(case-branch (cadar exprs) selector (list (caddar exprs)))
- (else ,(car (cdddar exprs))))
- (list (case-branch (cadar exprs) selector (cddar exprs)))))))
- (else #f)))))))
- (lint-walk-open-body caller head exprs env))))
- (cddr form))
-
- (if (and has-else
- (pair? result)
- (not else-foldable))
- (begin
- (lint-format "perhaps ~A" caller (lists->string form
- (if (null? (cdr result))
- (car result)
- `(begin , at result))))
- (set! exprs-repeated #f)))
-
- (when (or exprs-repeated else-foldable)
- (let ((new-keys-and-exprs ())
- (mergers ())
- (else-clause (if else-foldable
- (call-with-exit
- (lambda (return)
- (for-each (lambda (c) (if (eq? (car c) 'else) (return c))) else-foldable)
- ()))
- (or has-else ()))))
-
- (define merge-case-keys
- (let ((else-exprs (and (pair? else-clause) (cdr else-clause))))
- (define (a-few lst)
- (if (> (length lst) 3)
- (copy lst (make-list 4 '...) 0 3)
- lst))
- (lambda (clause)
- (let ((keys (car clause))
- (exprs (cdr clause)))
- (when (and (pair? exprs) ; ignore clauses that are messed up
- (not (eq? keys 'else))
- (not (equal? exprs else-exprs)))
- (let ((prev (member exprs new-keys-and-exprs (lambda (a b) (equal? a (cdr b))))))
- (if prev
- (let* ((cur-clause (car prev))
- (cur-keys (car cur-clause)))
- (when (pair? cur-keys)
- (set! mergers (cons (list (a-few keys) (a-few cur-keys)) mergers))
- (set-car! cur-clause
- (append cur-keys
- (map (lambda (key)
- (if (memv key cur-keys) (values) key))
- keys)))))
- (set! new-keys-and-exprs (cons (cons (copy (car clause)) (cdr clause)) new-keys-and-exprs)))))))))
-
- (for-each merge-case-keys (cddr form))
- (if (pair? else-foldable)
- (for-each merge-case-keys else-foldable))
-
- (if (null? new-keys-and-exprs)
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (or (null? else-clause) ; can this happen? (it's caught above as an error)
- (null? (cdr else-clause)))
- ()
- (if (null? (cddr else-clause))
- (cadr else-clause)
- `(begin ,@(cdr else-clause))))))
+ (if (not (side-effect? form env))
+ (let ((end+result (caddr form)))
+ (if (or (not (pair? end+result))
+ (null? (cdr end+result)))
+ (lint-format "this do-loop could be replaced by (): ~A" caller (truncated-list->string form))
+ (if (and (null? (cddr end+result))
+ (code-constant? (cadr end+result)))
+ (lint-format "this do-loop could be replaced by ~A: ~A" caller (cadr end+result) (truncated-list->string form))))))
+
+ ;; walk the init forms before adding the step vars to env
+ (do ((bindings step-vars (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "do variable list is not a proper list? ~S" caller step-vars)))
+ (when (binding-ok? caller 'do (car bindings) env #f)
+ (for-each (lambda (v)
+ (if (and (not (eq? (var-initial-value v) (var-name v)))
+ (tree-memq (var-name v) (cadar bindings))
+ (not (hash-table-ref built-in-functions (var-name v)))
+ (not (tree-table-member binders (cadar bindings))))
+ (if (not (var-member (var-name v) env))
+ (lint-format "~A in ~A does not appear to be defined in the calling environment" caller
+ (var-name v) (car bindings))
+ (lint-format "~A in ~A refers to the caller's ~A, not the do-loop variable" caller
+ (var-name v) (car bindings) (var-name v)))))
+ vars)
+
+ (lint-walk caller (cadar bindings) env)
+ (set! vars (cons (let ((v (make-var :name (caar bindings)
+ :definer 'do
+ :initial-value (cadar bindings))))
+ (let ((stepper (and (pair? (cddar bindings)) (caddar bindings))))
+ (varlet (cdr v) :step stepper)
+ (if stepper (set! (var-history v) (cons (list 'set! (caar bindings) stepper) (var-history v)))))
+ v)
+ vars))))
+
+ (set! inner-env (append vars env))
+
+ ;; walk the step exprs
+ (let ((baddies ())) ; these are step vars (with step exprs) used within other step vars step expressions
+ (do ((bindings step-vars (cdr bindings)))
+ ((not (pair? bindings)))
+ (let ((stepper (car bindings))) ; the entire binding: '(i 0 (+ i 1))
+ (when (and (binding-ok? caller 'do stepper env #t)
+ (pair? (cddr stepper)))
+ (let ((data (var-member (car stepper) vars)))
+ (let ((old-ref (var-ref data)))
+ (lint-walk caller (caddr stepper) inner-env)
+ (set! (var-ref data) old-ref))
+ (if (eq? (car stepper) (caddr stepper)) ; (i 0 i) -> (i 0)
+ (lint-format "perhaps ~A" caller (lists->string stepper (list (car stepper) (cadr stepper)))))
+ ;; pointless caddr here happens very rarely
+ (set! (var-set data) (+ (var-set data) 1))) ; (pair? cddr) above
+ (when (and (pair? (caddr stepper))
+ (not (eq? (car stepper) (cadr stepper))) ; (lst lst (cdr lst))
+ (eq? (car (caddr stepper)) 'cdr)
+ (eq? (cadr stepper) (cadr (caddr stepper))))
+ (lint-format "this looks suspicious: ~A" caller stepper))
+ (for-each (lambda (v)
+ (if (and (var-step v)
+ (not (eq? (var-name v) (car stepper)))
+ (or (eq? (var-name v) (caddr stepper))
+ (and (pair? (caddr stepper))
+ (tree-unquoted-member (var-name v) (caddr stepper)))))
+ (set! baddies (cons (car stepper) baddies))))
+ vars))))
+
+ (check-unordered-exprs caller form (map var-initial-value vars) env)
+
+ (when (pair? baddies)
+ ;; (do ((i 0 j) (j ...))...) is unreadable -- which (binding of) j is i set to?
+ ;; but this is tricky if there is more than one such variable -- if cross links, we'll need named let
+ ;; and if no step expr, there's no confusion.
+ ;; (do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4)) (format *stderr* "~A ~A~%" i j))
+ ;; (let __1__ ((i 0) (j 1) (k 0)) (if (= k 4) () (begin (format *stderr* "~A ~A~%" i j) (__1__ j i (+ k 1)))))
+ (let ((new-steppers (map (lambda (stepper)
+ (if (memq (car stepper) baddies)
+ `(,(car stepper) ,(cadr stepper))
+ stepper))
+ step-vars))
+ (new-sets (map (lambda (stepper)
+ (if (memq (car stepper) baddies)
+ `(set! ,(car stepper) ,(caddr stepper))
+ (values)))
+ step-vars)))
+ (if (or (null? (cdr baddies))
+ (let ((trails new-sets))
+ (not (any? (lambda (v) ; for each baddy, is it used in any following set!?
+ (and (pair? (cdr trails))
+ (set! trails (cdr trails))
+ (tree-unquoted-member v trails)))
+ (reverse baddies)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(do ,new-steppers
+ ,(caddr form)
+ ,@(cdddr form)
+ , at new-sets)))
+ (let* ((loop (find-unique-name form))
+ (test (if (pair? (caddr form))
+ (caaddr form)
+ ()))
+ (result (if (not (and (pair? (caddr form))
+ (pair? (cdaddr form))))
+ ()
+ (if (null? (cdr (cdaddr form)))
+ (car (cdaddr form))
+ `(begin ,@(cdaddr form)))))
+ (let-loop `(,loop ,@(map (lambda (s)
+ ((if (pair? (cddr s)) caddr car) s))
+ step-vars)))
+ (new-body (if (pair? (cdddr form))
+ `(begin ,@(cdddr form) ,let-loop)
+ let-loop)))
+ (lint-format "this do loop is unreadable; perhaps ~A" caller
+ (lists->string form
+ `(let ,loop ,(map (lambda (s)
+ (list (car s) (cadr s)))
+ step-vars)
+ (if ,test ,result ,new-body)))))))))
+
+ ;; walk the body and end stuff (it's too tricky to find infinite do loops)
+ (when (pair? (caddr form))
+ (let ((end+result (caddr form)))
+ (when (pair? end+result)
+ (let ((end (car end+result)))
+ (lint-walk caller end inner-env) ; this will call simplify-boolean
+ (if (pair? (cdr end+result))
+ (if (null? (cddr end+result))
(begin
- ;; (null? (cdr new-keys-and-exprs)) is rare and kinda dumb -- cases look like test suite entries
- (for-each
- (lambda (clause)
- (if (and (pair? (car clause))
- (pair? (cdar clause)))
- (if (every? integer? (car clause))
- (set-car! clause (sort! (car clause) <))
- (if (every? char? (car clause))
- (set-car! clause (sort! (car clause) char<?))))))
- new-keys-and-exprs)
- (let ((new-form (if (pair? else-clause)
- `(case ,(cadr form) ,@(reverse new-keys-and-exprs) ,else-clause)
- `(case ,(cadr form) ,@(reverse new-keys-and-exprs)))))
- (lint-format "perhaps ~A" caller
- (if (pair? mergers)
- (format #f "merge keys ~{~{~A with ~A~}~^, ~}: ~A"
- (reverse mergers)
- (lists->string form new-form))
- (lists->string form new-form)))))))))))
- env)
-
- ;; ---------------- do ----------------
- ((do)
- (let ((vars ()))
- (if (not (and (>= (length form) 3)
- (proper-list? (cadr form))
- (proper-list? (caddr form))))
- (lint-format "do is messed up: ~A" caller (truncated-list->string form))
-
- (let ((step-vars (cadr form))
- (inner-env #f))
-
- (define (var-step v) ((cdr v) 'step))
-
- (if (not (side-effect? form env))
- (let ((end+result (caddr form)))
- (if (or (not (pair? end+result))
- (null? (cdr end+result)))
- (lint-format "this do-loop could be replaced by (): ~A" caller (truncated-list->string form))
- (if (and (null? (cddr end+result))
- (code-constant? (cadr end+result)))
- (lint-format "this do-loop could be replaced by ~A: ~A" caller (cadr end+result) (truncated-list->string form))))))
+ (if (any-null? (cadr end+result))
+ (lint-format "nil return value is redundant: ~A" caller end+result))
+ (lint-walk caller (cadr end+result) inner-env))
+ (lint-walk-open-body caller 'do-result (cdr end+result) inner-env)))
+ (if (and (symbol? end) (memq end '(= > < >= <= null? not)))
+ (lint-format "perhaps missing parens: ~A" caller end+result))
+
+ (cond ((never-false end)
+ (lint-format "end test is never false: ~A" caller end))
+
+ (end ; it's not #f
+ (if (never-true end)
+ (lint-format "end test is never true: ~A" caller end)
+ (let ((v (and (pair? end)
+ (memq (car end) '(< > <= >=))
+ (pair? (cdr end))
+ (symbol? (cadr end))
+ (var-member (cadr end) vars))))
+ ;; if found, v is the var info
+ (when (pair? v)
+ (let ((step (var-step v)))
+ (when (pair? step)
+ (let ((inc (and (memq (car step) '(+ -))
+ (pair? (cdr step))
+ (pair? (cddr step))
+ (or (and (real? (cadr step)) (cadr step))
+ (and (real? (caddr step)) (caddr step))))))
+ (when (and (real? inc)
+ (case (car step)
+ ((+) (and (positive? inc)
+ (memq (car end) '(< <=))))
+ ((-) (and (positive? inc)
+ (memq (car end) '(> >=))))
+ (else #f)))
+ (lint-format "do step looks like it doesn't match end test: ~A" caller
+ (lists->string step end))))))))))
+ ((pair? (cdr end+result))
+ (lint-format "result is unreachable: ~A" caller end+result)))
- ;; walk the init forms before adding the step vars to env
- (do ((bindings step-vars (cdr bindings)))
- ((not (pair? bindings))
- (if (not (null? bindings))
- (lint-format "do variable list is not a proper list? ~S" caller step-vars)))
- (when (binding-ok? caller head (car bindings) env #f)
+ (if (and (symbol? end)
+ (not (var-member end env))
+ (procedure? (symbol->value end *e*)))
+ (lint-format "strange do end-test: ~A in ~A is a procedure" caller end end+result))))))
+
+ (lint-walk-body caller 'do (cdddr form) (cons (make-var :name :let
+ :initial-value form
+ :definer 'do)
+ inner-env))
+
+ ;; before report-usage, check for unused variables, and don't complain about them if
+ ;; they are referenced in an earlier step expr.
+ (do ((v vars (cdr v)))
+ ((null? v))
+ (let ((var (car v)))
+ (when (zero? (var-ref var))
+ ;; var was not seen in the end+result/body or any subsequent step exprs
+ ;; vars is reversed order, so we need only scan var-step of the rest
+ (if (side-effect? (var-step var) env)
+ (set! (var-ref var) (+ (var-ref var) 1))
+ (for-each
+ (lambda (nv)
+ (if (or (eq? (var-name var) (var-step nv))
+ (and (pair? (var-step nv))
+ (tree-unquoted-member (var-name var) (var-step nv))))
+ (set! (var-ref var) (+ (var-ref var) 1))))
+ (cdr v))))))
+ (report-usage caller 'do vars inner-env)
+
+ ;; look for constant expressions in the do body
+ (when *report-constant-expressions-in-do*
+ (let ((constant-exprs (find-constant-exprs 'do (map var-name vars) (cdddr form))))
+ (if (pair? constant-exprs)
+ (if (null? (cdr constant-exprs))
+ (lint-format "in ~A, ~A appears to be constant" caller
+ (truncated-list->string form)
+ (car constant-exprs))
+ (lint-format "in ~A, the following expressions appear to be constant:~%~NC~A" caller
+ (truncated-list->string form)
+ (+ lint-left-margin 4) #\space
+ (format #f "~{~A~^, ~}" constant-exprs))))))
+
+ ;; if simple lambda expanded and exists only for the loop, remove let as well?
+ ;; this can sometimes be simplified
+ (let ((body (cdddr form)))
+ (when (and (pair? body)
+ (null? (cdr body))
+ (pair? (car body)))
+ (let ((v (var-member (caar body) env)))
+ (when (and (var? v)
+ (memq (var-ftype v) '(define lambda)))
+ (let* ((vfunc (var-initial-value v))
+ (vbody (cddr vfunc)))
+ ;; we already detect a do body with no side-effects (walk-body)
+ (if (and (proper-list? ((if (eq? (var-ftype v) 'define) cdadr cadr) vfunc))
+ (null? (cdr vbody))
+ (< (tree-leaves vbody) 16))
+ (do ((pp (var-arglist v) (cdr pp)))
+ ((or (null? pp)
+ (> (tree-count1 (car pp) vbody 0) 1))
+ (when (null? pp)
+ (let ((new-body (copy vbody)))
+ (for-each (lambda (par arg)
+ (if (not (eq? par arg))
+ (set! new-body (tree-subst arg par new-body))))
+ (var-arglist v)
+ (cdar body))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(do ,(cadr form)
+ ,(caddr form)
+ , at new-body)))))))))))))
+
+ ;; check for do-loop as copy/fill! stand-in and other similar cases
+ (when (and (pair? vars)
+ (null? (cdr vars)))
+ (let ((end-test (and (pair? (caddr form)) (caaddr form)))
+ (first-var (caadr form))
+ (body (cdddr form))
+ (setv #f))
+ (when (and (pair? end-test)
+ (pair? body)
+ (null? (cdr body))
+ (pair? (car body))
+ (memq (car end-test) '(>= =)))
+ (let ((vname (car first-var))
+ (start (cadr first-var))
+ (step (and (pair? (cddr first-var))
+ (caddr first-var)))
+ (end (caddr end-test)))
+ (when (and (pair? step)
+ (eq? (car step) '+)
+ (memq vname step)
+ (memv 1 step)
+ (null? (cdddr step))
+ (or (eq? (cadr end-test) vname)
+ (and (eq? (car end-test) '=)
+ (eq? (caddr end-test) vname)
+ (set! end (cadr end-test)))))
+ ;; we have (do ((v start (+ v 1)|(+ 1 v))) ((= v end)|(= end v)|(>= v end)) one-statement)
+ (set! body (car body))
+ ;; write-char is the only other common case here -> write-string in a few cases
+ (when (and (memq (car body) '(vector-set! float-vector-set! int-vector-set! list-set! string-set! byte-vector-set!))
+ ;; integer type check here isn't needed because we're using this as an index below
+ ;; the type error will be seen in report-usage if not earlier
+ (eq? (caddr body) vname)
+ (let ((val (cadddr body)))
+ (set! setv val)
+ (or (code-constant? val)
+ (and (pair? val)
+ (memq (car val) '(vector-ref float-vector-ref int-vector-ref list-ref string-ref byte-vector-ref))
+ (eq? (caddr val) vname)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (code-constant? setv)
+ `(fill! ,(cadr body) ,(cadddr body) ,start ,end)
+ `(copy ,(cadr setv) ,(cadr body) ,start ,end))))))))))))
+ env))
+ (hash-table-set! h 'do do-walker))
+
+
+ ;; ---------------- let ----------------
+ (let ()
+ (define (let-walker caller form env)
+ (if (or (< (length form) 3)
+ (not (or (symbol? (cadr form))
+ (list? (cadr form)))))
+ (lint-format "let is messed up: ~A" caller (truncated-list->string form))
+ (let ((named-let (and (symbol? (cadr form)) (cadr form))))
+ (if (keyword? named-let)
+ (lint-format "bad let name: ~A" caller named-let))
+ (unless named-let
+
+ (if (and (null? (cadr form)) ; this can be fooled by macros that define things
+ (eq? form lint-current-form) ; i.e. we're in a body?
+ (not (tree-set-member '(call/cc call-with-current-continuation lambda lambda* define define*
+ define-macro define-macro* define-bacro define-bacro* define-constant define-expansion
+ load eval eval-string require)
+ (cddr form))))
+ (lint-format "pointless let: ~A" caller (truncated-list->string form))
+ (let ((body (cddr form)))
+ (when (and (null? (cdr body))
+ (pair? (car body)))
+ (if (memq (caar body) '(let let*))
+ (if (null? (cadr form))
+ (lint-format "pointless let: ~A" caller (lists->string form (car body)))
+ (if (null? (cadar body))
+ (lint-format "pointless let: ~A" caller (lists->string form `(let ,(cadr form) ,@(cddar body))))))
+ (if (and (memq (caar body) '(lambda lambda*)) ; or any definer?
+ (null? (cadr form)))
+ (lint-format "pointless let: ~A" caller (lists->string form (car body)))))))))
+
+ (let ((vars (if (or (not named-let)
+ (keyword? named-let)
+ (not (or (null? (caddr form))
+ (and (proper-list? (caddr form))
+ (every? pair? (caddr form))))))
+ ()
+ (list (make-fvar :name named-let
+ :ftype 'let
+ :decl (dummy-func caller form (list 'define (cons '_ (map car (caddr form))) #f))
+ :arglist (map car (caddr form))
+ :initial-value form
+ :env env))))
+ (varlist ((if named-let caddr cadr) form))
+ (body ((if named-let cdddr cddr) form)))
+
+ (if (not (list? varlist))
+ (lint-format "let is messed up: ~A" caller (truncated-list->string form))
+ (if (and (null? varlist)
+ (pair? body)
+ (null? (cdr body))
+ (not (side-effect? (car body) env)))
+ (lint-format "perhaps ~A" caller (lists->string form (car body)))))
+
+ (do ((bindings varlist (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "let variable list is not a proper list? ~S" caller varlist)))
+ (when (binding-ok? caller 'let (car bindings) env #f)
+ (let ((val (cadar bindings)))
+ (if (and (pair? val)
+ (eq? 'lambda (car val))
+ (tree-car-member (caar bindings) val)
+ (not (var-member (caar bindings) env)))
+ (lint-format "let variable ~A is called in its binding? Perhaps let should be letrec: ~A"
+ caller (caar bindings)
+ (truncated-list->string bindings))
+ (unless named-let
(for-each (lambda (v)
- (if (and (not (eq? (var-initial-value v) (var-name v)))
- (tree-memq (var-name v) (cadar bindings))
+ (if (and (tree-memq (var-name v) (cadar bindings))
(not (hash-table-ref built-in-functions (var-name v)))
(not (tree-table-member binders (cadar bindings))))
(if (not (var-member (var-name v) env))
(lint-format "~A in ~A does not appear to be defined in the calling environment" caller
(var-name v) (car bindings))
- (lint-format "~A in ~A refers to the caller's ~A, not the do-loop variable" caller
+ (lint-format "~A in ~A refers to the caller's ~A, not the let variable" caller
(var-name v) (car bindings) (var-name v)))))
- vars)
-
- (lint-walk caller (cadar bindings) env)
- (set! vars (cons (let ((v (make-var :name (caar bindings)
- :definer 'do
- :initial-value (cadar bindings))))
- (let ((stepper (and (pair? (cddar bindings)) (caddar bindings))))
- (varlet (cdr v) :step stepper)
- (if stepper (set! (var-history v) (cons (list 'set! (caar bindings) stepper) (var-history v)))))
- v)
- vars))))
-
- (set! inner-env (append vars env))
-
- ;; walk the step exprs
- (let ((baddies ())) ; these are step vars (with step exprs) used within other step vars step expressions
- (do ((bindings step-vars (cdr bindings)))
- ((not (pair? bindings)))
- (let ((stepper (car bindings))) ; the entire binding: '(i 0 (+ i 1))
- (when (and (binding-ok? caller head stepper env #t)
- (pair? (cddr stepper)))
- (let ((data (var-member (car stepper) vars)))
- (let ((old-ref (var-ref data)))
- (lint-walk caller (caddr stepper) inner-env)
- (set! (var-ref data) old-ref))
- (if (eq? (car stepper) (caddr stepper)) ; (i 0 i) -> (i 0)
- (lint-format "perhaps ~A" caller (lists->string stepper (list (car stepper) (cadr stepper)))))
- ;; pointless caddr here happens very rarely
- (set! (var-set data) (+ (var-set data) 1))) ; (pair? cddr) above
- (when (and (pair? (caddr stepper))
- (not (eq? (car stepper) (cadr stepper))) ; (lst lst (cdr lst))
- (eq? (car (caddr stepper)) 'cdr)
- (eq? (cadr stepper) (cadr (caddr stepper))))
- (lint-format "this looks suspicious: ~A" caller stepper))
- (for-each (lambda (v)
- (if (and (var-step v)
- (not (eq? (var-name v) (car stepper)))
- (or (eq? (var-name v) (caddr stepper))
- (and (pair? (caddr stepper))
- (tree-unquoted-member (var-name v) (caddr stepper)))))
- (set! baddies (cons (car stepper) baddies))))
- vars))))
-
- (check-unordered-exprs caller form (map var-initial-value vars) env)
-
- (when (pair? baddies)
- ;; (do ((i 0 j) (j ...))...) is unreadable -- which (binding of) j is i set to?
- ;; but this is tricky if there is more than one such variable -- if cross links, we'll need named let
- ;; and if no step expr, there's no confusion.
- ;; (do ((i 0 j) (j 1 i) (k 0 (+ k 1))) ((= k 4)) (format *stderr* "~A ~A~%" i j))
- ;; (let __1__ ((i 0) (j 1) (k 0)) (if (= k 4) () (begin (format *stderr* "~A ~A~%" i j) (__1__ j i (+ k 1)))))
- (let ((new-steppers (map (lambda (stepper)
- (if (memq (car stepper) baddies)
- `(,(car stepper) ,(cadr stepper))
- stepper))
- step-vars))
- (new-sets (map (lambda (stepper)
- (if (memq (car stepper) baddies)
- `(set! ,(car stepper) ,(caddr stepper))
- (values)))
- step-vars)))
- (if (or (null? (cdr baddies))
- (let ((trails new-sets))
- (not (any? (lambda (v) ; for each baddy, is it used in any following set!?
- (and (pair? (cdr trails))
- (set! trails (cdr trails))
- (tree-unquoted-member v trails)))
- (reverse baddies)))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(do ,new-steppers
- ,(caddr form)
- ,@(cdddr form)
- , at new-sets)))
- (let* ((loop (find-unique-name form #f))
- (test (if (pair? (caddr form))
- (caaddr form)
- ()))
- (result (if (not (and (pair? (caddr form))
- (pair? (cdaddr form))))
- ()
- (if (null? (cdr (cdaddr form)))
- (car (cdaddr form))
- `(begin ,@(cdaddr form)))))
- (let-loop `(,loop ,@(map (lambda (s)
- (if (pair? (cddr s))
- (caddr s)
- (car s)))
- step-vars)))
- (new-body (if (pair? (cdddr form))
- `(begin ,@(cdddr form) ,let-loop)
- let-loop)))
- (lint-format "this do loop is unreadable; perhaps ~A" caller
- (lists->string form
- `(let ,loop ,(map (lambda (s)
- (list (car s) (cadr s)))
- step-vars)
- (if ,test ,result ,new-body)))))))))
-
- ;; walk the body and end stuff (it's too tricky to find infinite do loops)
- (when (pair? (caddr form))
- (let ((end+result (caddr form)))
- (when (pair? end+result)
- (let ((end (car end+result)))
- (lint-walk caller end inner-env) ; this will call simplify-boolean
- (if (pair? (cdr end+result))
- (if (null? (cddr end+result))
- (lint-walk caller (cadr end+result) inner-env)
- (lint-walk-open-body caller 'do-result (cdr end+result) inner-env)))
- (if (and (symbol? end) (memq end '(= > < >= <= null? not)))
- (lint-format "perhaps missing parens: ~A" caller end+result))
-
- (cond ((never-false end)
- (lint-format "end test is never false: ~A" caller end))
-
- (end ; it's not #f
- (if (never-true end)
- (lint-format "end test is never true: ~A" caller end)
- (let ((v (and (pair? end)
- (memq (car end) '(< > <= >=))
- (pair? (cdr end))
- (symbol? (cadr end))
- (var-member (cadr end) vars))))
- ;; if found, v is the var info
- (when (pair? v)
- (let ((step (var-step v)))
- (when (pair? step)
- (let ((inc (and (memq (car step) '(+ -))
- (pair? (cdr step))
- (pair? (cddr step))
- (or (and (real? (cadr step)) (cadr step))
- (and (real? (caddr step)) (caddr step))))))
- (when (and (real? inc)
- (case (car step)
- ((+) (and (positive? inc)
- (memq (car end) '(< <=))))
- ((-) (and (positive? inc)
- (memq (car end) '(> >=))))
- (else #f)))
- (lint-format "do step looks like it doesn't match end test: ~A" caller
- (lists->string step end))))))))))
- ((pair? (cdr end+result))
- (lint-format "result is unreachable: ~A" caller end+result)))
-
- (if (and (symbol? end)
- (not (var-member end env))
- (procedure? (symbol->value end *e*)))
- (lint-format "strange do end-test: ~A in ~A is a procedure" caller end end+result))))))
-
- (lint-walk-body caller head (cdddr form) inner-env)
-
- ;; before report-usage, check for unused variables, and don't complain about them if
- ;; they are referenced in an earlier step expr.
- (do ((v vars (cdr v)))
- ((null? v))
- (let ((var (car v)))
- (when (zero? (var-ref var))
- ;; var was not seen in the end+result/body or any subsequent step exprs
- ;; vars is reversed order, so we need only scan var-step of the rest
- (if (side-effect? (var-step var) env)
- (set! (var-ref var) (+ (var-ref var) 1))
- (for-each
- (lambda (nv)
- (if (or (eq? (var-name var) (var-step nv))
- (and (pair? (var-step nv))
- (tree-unquoted-member (var-name var) (var-step nv))))
- (set! (var-ref var) (+ (var-ref var) 1))))
- (cdr v))))))
- (report-usage caller head vars inner-env)
-
- ;; look for constant expressions in the do body
- (when *report-constant-expressions-in-do*
- (let ((constant-exprs (find-constant-exprs 'do (map var-name vars) (cdddr form))))
- (if (pair? constant-exprs)
- (if (null? (cdr constant-exprs))
- (lint-format "in ~A, ~A appears to be constant" caller
- (truncated-list->string form)
- (car constant-exprs))
- (lint-format "in ~A, the following expressions appear to be constant:~%~NC~A" caller
- (truncated-list->string form)
- (+ lint-left-margin 4) #\space
- (format #f "~{~A~^, ~}" constant-exprs))))))
-
- ;; if simple lambda expanded and exists only for the loop, remove let as well?
- ;; this can sometimes be simplified
- (let ((body (cdddr form)))
- (when (and (pair? body)
- (null? (cdr body))
- (pair? (car body)))
- (let ((v (var-member (caar body) env)))
- (when (and (var? v)
- (memq (var-ftype v) '(define lambda)))
- (let* ((vfunc (var-initial-value v))
- (vbody (cddr vfunc)))
- ;; we already detect a do body with no side-effects (walk-body)
- (if (and (proper-list? (if (eq? (var-ftype v) 'define) (cdadr vfunc) (cadr vfunc)))
- (null? (cdr vbody))
- (< (tree-leaves vbody) 16))
- (do ((pp (var-arglist v) (cdr pp)))
- ((or (null? pp)
- (> (tree-count1 (car pp) vbody 0) 1))
- (when (null? pp)
- (let ((new-body (copy vbody)))
- (for-each (lambda (par arg)
- (if (not (eq? par arg))
- (set! new-body (tree-subst arg par new-body))))
- (var-arglist v)
- (cdar body))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(do ,(cadr form)
- ,(caddr form)
- , at new-body)))))))))))))
-
- ;; check for do-loop as copy/fill! stand-in and other similar cases
- (when (and (pair? vars)
- (null? (cdr vars)))
- (let ((end-test (and (pair? (caddr form)) (caaddr form)))
- (first-var (caadr form))
- (body (cdddr form))
- (setv #f))
- (when (and (pair? end-test)
- (pair? body)
- (null? (cdr body))
- (pair? (car body))
- (memq (car end-test) '(>= =)))
- (let ((vname (car first-var))
- (start (cadr first-var))
- (step (and (pair? (cddr first-var))
- (caddr first-var)))
- (end (caddr end-test)))
- (when (and step
- (pair? step)
- (eq? (car step) '+)
- (memq vname step)
- (memv 1 step)
- (null? (cdddr step))
- (or (eq? (cadr end-test) vname)
- (and (eq? (car end-test) '=)
- (eq? (caddr end-test) vname)
- (set! end (cadr end-test)))))
- ;; we have (do ((v start (+ v 1)|(+ 1 v))) ((= v end)|(= end v)|(>= v end)) one-statement)
- (set! body (car body))
- ;; write-char is the only other common case here -> write-string in a few cases
- (when (and (memq (car body) '(vector-set! float-vector-set! int-vector-set! list-set! string-set! byte-vector-set!))
- ;; integer type check here isn't needed because we're using this as an index below
- ;; the type error will be seen in report-usage if not earlier
- (eq? (caddr body) vname)
- (let ((val (cadddr body)))
- (set! setv val)
- (or (code-constant? val)
- (and (pair? val)
- (memq (car val) '(vector-ref float-vector-ref int-vector-ref list-ref string-ref byte-vector-ref))
- (eq? (caddr val) vname)))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (code-constant? setv)
- `(fill! ,(cadr body) ,(cadddr body) ,start ,end)
- `(copy ,(cadr setv) ,(cadr body) ,start ,end))))))))))))
- env))
-
- ;; ---------------- let ----------------
- ((let)
- (if (or (< (length form) 3)
- (not (or (symbol? (cadr form))
- (list? (cadr form)))))
- (lint-format "let is messed up: ~A" caller (truncated-list->string form))
- (let ((named-let (and (symbol? (cadr form)) (cadr form))))
- (if (keyword? named-let)
- (lint-format "bad let name: ~A" caller named-let))
- (unless named-let
-
- (if (and (null? (cadr form)) ; this can be fooled by macros that define things
- (eq? form lint-current-form) ; i.e. we're in a body?
- (not (tree-set-member '(call/cc call-with-current-continuation lambda lambda* define define*
- define-macro define-macro* define-bacro define-bacro* define-constant define-expansion
- load eval eval-string require)
- (cddr form))))
- (lint-format "pointless let: ~A" caller (truncated-list->string form))
-
- (let ((body (cddr form)))
- (if (and (null? (cdr body))
- (pair? (car body)))
- (if (memq (caar body) '(let let*))
- (if (null? (cadr form))
- (lint-format "pointless let: ~A" caller (lists->string form (car body)))
- (if (null? (cadar body))
- (lint-format "pointless let: ~A" caller (lists->string form `(let ,(cadr form) ,@(cddar body))))))
- (if (and (memq (caar body) '(lambda lambda*)) ; or any definer?
- (null? (cadr form)))
- (lint-format "pointless let: ~A" caller (lists->string form (car body)))))))))
-
- (let ((vars (if (and named-let
- (not (keyword? named-let))
- (or (null? (caddr form))
- (and (proper-list? (caddr form))
- (every? pair? (caddr form)))))
- (list (make-fvar :name named-let
- :ftype head
- :decl (dummy-func caller form (list 'define (cons '_ (map car (caddr form))) #f))
- :arglist (map car (caddr form))
- :initial-value form
- :env env))
- ()))
- (varlist (if named-let (caddr form) (cadr form)))
- (body (if named-let (cdddr form) (cddr form))))
-
- (if (not (list? varlist))
- (lint-format "let is messed up: ~A" caller (truncated-list->string form))
- (if (and (null? varlist)
- (pair? body)
- (null? (cdr body))
- (not (side-effect? (car body) env)))
- (lint-format "perhaps ~A" caller (lists->string form (car body)))))
-
- (do ((bindings varlist (cdr bindings)))
- ((not (pair? bindings))
- (if (not (null? bindings))
- (lint-format "let variable list is not a proper list? ~S" caller varlist)))
- (when (binding-ok? caller head (car bindings) env #f)
- (let ((val (cadar bindings)))
- (if (and (pair? val)
- (eq? 'lambda (car val))
- (tree-car-member (caar bindings) val)
- (not (var-member (caar bindings) env)))
- (lint-format "let variable ~A is called in its binding? Perhaps let should be letrec: ~A"
- caller (caar bindings)
- (truncated-list->string bindings))
- (unless named-let
- (for-each (lambda (v)
- (if (and (tree-memq (var-name v) (cadar bindings))
- (not (hash-table-ref built-in-functions (var-name v)))
- (not (tree-table-member binders (cadar bindings))))
- (if (not (var-member (var-name v) env))
- (lint-format "~A in ~A does not appear to be defined in the calling environment" caller
- (var-name v) (car bindings))
- (lint-format "~A in ~A refers to the caller's ~A, not the let variable" caller
- (var-name v) (car bindings) (var-name v)))))
- vars)))
- (lint-walk caller val env)
- (set! vars (cons (make-var :name (caar bindings)
- :initial-value val
- :definer (if named-let 'named-let 'let))
- vars)))))
-
- (check-unordered-exprs caller form
- (map (if (not named-let)
- var-initial-value
- (lambda (v)
- (if (eq? (var-name v) named-let)
- (values)
- (var-initial-value v))))
- vars)
- env)
-
- (let ((suggest made-suggestion))
- (when (and (pair? varlist) ; (let ((x (A))) (if x (f x) B)) -> (cond ((A) => f) (else B)
- (pair? (car varlist)) ; ^ this happens a lot, so it's worth this tedious search
- (null? (cdr varlist)) ; also (let ((x (A))) (cond (x (f x))...)
- (pair? body)
- (null? (cdr body))
- (pair? (cdar varlist))
- (pair? (cadar varlist)))
- (let ((p (car body))
- (vname (caar varlist))
- (vvalue (cadar varlist)))
-
- (when (and (not named-let) ; (let ((x (assq a y))) (set! z (if x (cadr x) 0))) -> (set! z (cond ((assq a y) => cadr) (else 0)))
- (pair? p)
- (not (memq (car p) '(if cond)))
- (= (tree-count2 vname p 0) 2))
- (do ((i 0 (+ i 1))
- (bp (cdr p) (cdr bp)))
- ((or (null? bp)
- (let ((b (car bp)))
- (and (pair? b)
- (eq? (car b) 'if)
- (= (tree-count2 vname b 0) 2)
- (eq? vname (cadr b))
- (pair? (caddr b))
- (pair? (cdaddr b))
- (null? (cddr (caddr b)))
- (eq? vname (cadr (caddr b))))))
- (if (pair? bp)
- (let ((else-clause (if (pair? (cdddar bp)) `((else ,@(cdddar bp))) ())))
- (set! last-assoc-form (car bp))
- (lint-format "perhaps ~A" caller
- (lists->string form `(,@(copy p (make-list (+ i 1)))
- (cond (,vvalue => ,(caaddr (car bp))) , at else-clause)
- ,@(cdr bp)))))))))
- (when (and (pair? p)
- (pair? (cdr p)))
- (when (and (eq? (car p) 'cond) ; (let ((x (f y))) (cond (x (g x)) ...)) -> (cond ((f y) => g) ...)
- (pair? (cadr p))
- (eq? (caadr p) vname)
- (pair? (cdadr p))
- (null? (cddadr p))
- (or (and (pair? (cadadr p))
- (pair? (cdr (cadadr p)))
- (null? (cddr (cadadr p))) ; one arg to func
- (eq? vname (cadr (cadadr p))))
- (eq? vname (cadadr p)))
- (or (null? (cddr p))
- (not (tree-unquoted-member vname (cddr p)))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (eq? vname (cadadr p))
- (if (and (pair? (cddr p))
- (pair? (caddr p))
- (memq (caaddr p) '(else #t t)))
- (if (null? (cddr (caddr p)))
- `(or ,vvalue ,(cadr (caddr p)))
- `(or ,vvalue (begin ,@(cdaddr p))))
- `(or ,vvalue
- (cond ,@(cddr p))))
- `(cond (,vvalue => ,(caadr (cadr p)))
- ,@(cddr p))))))
-
- (when (and (null? (cddr p)) ; (let ((x (+ y 1))) (abs x)) -> (abs (+ y 1))
- (eq? vname (cadr p))) ; not tree-subst or trailing (pair) args because then the let might be forcing evaluation order
- (let ((v (var-member (car p) env)))
- (if (or (and (var? v)
- (memq (var-definer v) '(define define* lambda lambda*)))
- (hash-table-ref built-in-functions (car p)))
- (lint-format "perhaps ~A" caller (lists->string form `(,(car p) ,vvalue)))
- (if (not (or (any-macro? vname env)
- (tree-unquoted-member vname (car p))))
- (lint-format "perhaps, assuming ~A is not a macro, ~A" caller (car p)
- (lists->string form `(,(car p) ,vvalue)))))))
-
- (when (pair? (cddr p))
- (when (and (pair? (cdddr p))
- (eq? (car p) 'if))
-
- (when (and (eq? (cadr p) vname) ; (let ((x (g y))) (if x #t #f)) -> (g y)
- (boolean? (caddr p))
- (boolean? (cadddr p))
- (not (eq? (caddr p) (cadddr p))))
- (lint-format "perhaps ~A" caller
- (lists->string form (if (caddr p) vvalue `(not ,vvalue)))))
-
- (when (and (pair? (cadr p)) ; (let ((x (f y))) (if (not x) B (g x))) -> (cond ((f y) => g) (else B))
- (eq? (caadr p) 'not)
- (eq? (cadadr p) vname)
- (pair? (cadddr p))
- (pair? (cdr (cadddr p)))
- (null? (cddr (cadddr p)))
- (eq? vname (cadr (cadddr p))))
- (let ((else-clause (if (eq? (caddr p) vname)
- `((else #f))
- (if (and (pair? (caddr p))
- (tree-unquoted-member vname (caddr p)))
- :oops! ; if the let var appears in the else portion, we can't do anything with =>
- `((else ,(caddr p)))))))
- (unless (eq? else-clause :oops!)
- (lint-format "perhaps ~A" caller (lists->string form `(cond (,vvalue => ,(car (cadddr p))) , at else-clause)))))))
-
- (let ((crf #f))
- ;; all this stuff still misses (cond ((not x)...)) and (set! y (if x (cdr x)...)) i.e. need embedding in this case
- (when (and (or (and (memq (car p) '(if and)) ; (let ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f))
- (eq? (cadr p) vname))
- (and (eq? (car p) 'or)
- (equal? (cadr p) `(not ,vname)))
- (and (pair? vvalue)
- (memq (car vvalue) '(assoc assv assq member memv memq))
- (pair? (cadr p))
- (or (eq? (caadr p) 'pair?)
- (and (eq? (caadr p) 'null?)
- (lint-format "in ~A, ~A can't be null because ~A in ~A only returns #f or a pair"
- caller p vname (car vvalue) (truncated-list->string (car varlist)))
- #f))
- (eq? (cadadr p) vname)))
-
- (or (and (pair? (caddr p))
- (pair? (cdaddr p))
- (null? (cddr (caddr p))) ; one func arg
- (or (eq? vname (cadr (caddr p)))
- (and (memq (caaddr p) '(car cdr caar cadr cddr cdar caaar caadr caddr
- cdddr cdaar cddar cadar cdadr cadddr cddddr))
- ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f
- (and cr
- (< (length cr) 5)
- (eq? vname arg)
- (set! crf (string->symbol (string-append "c" cr "r")))))
- (combine-cxrs (caddr p))))))
- (and (eq? (car p) 'if)
- (eq? (caddr p) vname)
- (not (tree-unquoted-member vname (cdddr p)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (null? (cdddr p))
- vvalue
- `(or ,vvalue ,(cadddr p)))))
- #f))
- (pair? (caddr p))
- (or (eq? (car p) 'if)
- (null? (cdddr p))))
- (let ((else-clause (cond ((pair? (cdddr p))
- (if (eq? (cadddr p) vname)
- `((else #f)) ; this stands in for the local var
- (if (and (pair? (cadddr p))
- (tree-unquoted-member vname (cadddr p)))
- :oops! ; if the let var appears in the else portion, we can't do anything with =>
- `((else ,(cadddr p))))))
- ((eq? (car p) 'and)
- `((else #f)))
- ((eq? (car p) 'or)
- `((else #t)))
- (else ()))))
- (set! last-assoc-form p)
- (unless (eq? else-clause :oops!)
- (lint-format "perhaps ~A" caller
- (lists->string form `(cond (,vvalue => ,(or crf (caaddr p))) , at else-clause))))))))
- ))) ; one var in varlist
-
- ;; --------
- ;; (let ((x 1) (y 2)) (+ x y)) -> (+ 1 2)
- ;; this happens a lot, but it often looks like a form of documentation
- (when (and (= suggest made-suggestion)
- (not named-let)
- (pair? varlist)
- (pair? body)
- (pair? (car body))
- (pair? (cdar body))
- (null? (cdr body))
- (< (length varlist) 8)
- (not (memq (caar body) '(lambda lambda* define define* define-macro)))
- (not (and (eq? (caar body) 'set!)
- (any? (lambda (v) (eq? (car v) (cadar body))) varlist)))
- (not (any-macro? (caar body) env))
- (not (any? (lambda (p)
- (and (pair? p)
- (not (eq? (car p) 'quote))
- (or (not (hash-table-ref no-side-effect-functions (car p)))
- (any? pair? (cdr p)))))
- (cdar body)))
- (every? (lambda (v)
- (and (pair? v)
- (pair? (cdr v))
- (< (tree-leaves (cadr v)) 8)
- (= (tree-count1 (car v) body 0) 1)))
- varlist))
- (let ((new-body (copy (car body)))
- (bool-arg? #f))
- (for-each (lambda (v)
- (if (not bool-arg?)
- (let tree-walk ((tree body))
- (if (pair? tree)
- (if (and (memq (car tree) '(or and))
- (memq (car v) (cdr tree)))
- (set! bool-arg? #t)
- (begin
- (tree-walk (car tree))
- (tree-walk (cdr tree)))))))
- (set! new-body (tree-subst (cadr v) (car v) new-body)))
- varlist)
- (lint-format (if bool-arg?
- "perhaps, ignoring short-circuit issues, ~A"
- "perhaps ~A")
- caller (lists->string form new-body))))
- ;; --------
- ) ; suggest let
-
+ vars)))
+ (lint-walk caller val env)
+ (set! vars (cons (make-var :name (caar bindings)
+ :initial-value val
+ :definer (if named-let 'named-let 'let))
+ vars)))))
+
+ (check-unordered-exprs caller form
+ (map (if (not named-let)
+ var-initial-value
+ (lambda (v)
+ (if (eq? (var-name v) named-let)
+ (values)
+ (var-initial-value v))))
+ vars)
+ env)
+
+ (let ((suggest made-suggestion))
+ (when (and (pair? varlist) ; (let ((x (A))) (if x (f x) B)) -> (cond ((A) => f) (else B)
+ (pair? body)
+ (pair? (car body))
+ (null? (cdr body))
+ (pair? (cdar body)))
+
+ (when (and (pair? (car varlist)) ; ^ this happens a lot, so it's worth this tedious search
+ (null? (cdr varlist)) ; also (let ((x (A))) (cond (x (f x))...)
+ (pair? (cdar varlist))
+ (pair? (cadar varlist)))
+
+ (let ((p (car body))
+ (vname (caar varlist))
+ (vvalue (cadar varlist)))
- (let* ((cur-env (append vars env))
- (e (lint-walk-body (or named-let caller) head body cur-env))
- (nvars (if (null? cur-env)
- e
- (and (not (eq? e cur-env))
- (env-difference caller e cur-env ())))))
- (if (pair? nvars)
- (if (eq? (var-name (car nvars)) :lambda)
- (begin
- (set! env (cons (car nvars) env))
- (set! nvars (cdr nvars)))
- (set! vars (append nvars vars))))
-
- (if (and (pair? body)
- (equal? (list-ref body (- (length body) 1)) '(curlet))) ; the standard library tag
- (for-each (lambda (v)
- (set! (var-ref v) (+ (var-ref v) 1)))
- e))
-
- (report-usage caller head vars cur-env))
+ (when (and (not named-let) ; (let ((x (assq a y))) (set! z (if x (cadr x) 0))) -> (set! z (cond ((assq a y) => cadr) (else 0)))
+ (not (memq (car p) '(if cond))) ; handled separately below
+ (= (tree-count2 vname p 0) 2))
+ (do ((i 0 (+ i 1))
+ (bp (cdr p) (cdr bp)))
+ ((or (null? bp)
+ (let ((b (car bp)))
+ (and (pair? b)
+ (eq? (car b) 'if)
+ (= (tree-count2 vname b 0) 2)
+ (eq? vname (cadr b))
+ (pair? (caddr b))
+ (pair? (cdaddr b))
+ (null? (cddr (caddr b)))
+ (eq? vname (cadr (caddr b))))))
+ (if (pair? bp)
+ (let ((else-clause (if (pair? (cdddar bp)) `((else ,@(cdddar bp))) ())))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,@(copy p (make-list (+ i 1)))
+ (cond (,vvalue => ,(caaddr (car bp))) , at else-clause)
+ ,@(cdr bp)))))))))
- (unless named-let
- (find-let-constant-exprs caller form vars body))
-
- ;; copied from letrec below -- happens about a dozen times
- (when (and (not named-let)
- (pair? varlist)
- (pair? (car varlist))
- (null? (cdr varlist))
- (pair? (cddr form))
- (pair? (caddr form))
- (null? (cdddr form)))
- (let ((body (caddr form))
- (sym (caar varlist))
- (lform (and (pair? (caadr form))
- (pair? (cdar (cadr form)))
- (cadar (cadr form)))))
- (if (and (pair? lform)
- (pair? (cdr lform))
- (eq? (car lform) 'lambda)
- (proper-list? (cadr lform)))
- ;; unlike in letrec, here there can't be recursion (ref to same name is ref to outer env)
- (if (eq? sym (car body))
- (if (not (tree-memq sym (cdr body)))
- (lint-format "perhaps ~A" caller
- (lists->string
- form `(let ,(map list (cadr lform) (cdr body))
- ,@(cddr lform)))))
- (if (= (tree-count1 sym body 0) 1)
- (let ((call (find-call sym body)))
- (when (pair? call)
- (let ((new-call `(let ,(map list (cadr lform) (cdr call))
- ,@(cddr lform))))
- (lint-format "perhaps ~A" caller
- (lists->string form (tree-subst new-call call body)))))))))))
-
-
- (if (and (pair? body) ; (let ((x y)) x) -> y
- (null? (cdr body))
- (pair? varlist) ; (let ()...)
- (pair? (car varlist)) ; (let (x) ...)
- (eq? (car body) (caar varlist))
- (null? (cdr varlist))
- (pair? (cdar varlist))) ; (let ((a))...)
- (lint-format "perhaps ~A" caller (lists->string form (cadar varlist))))
- ;; also (let ((x ...)) (let ((y x)...))) happens but it looks like automatically generated code or test suite junk
-
- (when (and (pair? body)
- (pair? (car body))
- (pair? (cdar body))
- (pair? (cddar body))
- (eq? (caar body) 'set!))
- (if (and (not named-let) ; (let ((x 0)...) (set! x 1)...) -> (let ((x 1)...)...)
- (not (tree-memq 'curlet (caddar body)))
- (cond ((assq (cadar body) vars)
- => (lambda (v)
- (or (and (code-constant? (var-initial-value v))
- (code-constant? (caddar body)))
- (not (any? (lambda (v1)
- (or (tree-memq (car v1) (caddar body))
- (side-effect? (cadr v1) env)))
- varlist)))))
- (else #f)))
+ (when (and (eq? (car p) 'cond) ; (let ((x (f y))) (cond (x (g x)) ...)) -> (cond ((f y) => g) ...)
+ (pair? (cadr p))
+ (eq? (caadr p) vname)
+ (pair? (cdadr p))
+ (null? (cddadr p))
+ (or (and (pair? (cadadr p))
+ (pair? (cdr (cadadr p)))
+ (null? (cddr (cadadr p))) ; one arg to func
+ (eq? vname (cadr (cadadr p))))
+ (eq? vname (cadadr p)))
+ (or (null? (cddr p))
+ (not (tree-unquoted-member vname (cddr p)))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (eq? vname (cadadr p))
+ (if (and (pair? (cddr p))
+ (pair? (caddr p))
+ (memq (caaddr p) '(else #t t)))
+ (if (null? (cddr (caddr p)))
+ `(or ,vvalue ,(cadr (caddr p)))
+ `(or ,vvalue (begin ,@(cdaddr p))))
+ `(or ,vvalue
+ (cond ,@(cddr p))))
+ `(cond (,vvalue => ,(caadr (cadr p)))
+ ,@(cddr p))))))
+
+ (when (and (null? (cddr p)) ; (let ((x (+ y 1))) (abs x)) -> (abs (+ y 1))
+ (eq? vname (cadr p))) ; not tree-subst or trailing (pair) args: the let might be forcing evaluation order
+ (let ((v (var-member (car p) env)))
+ (if (or (and (var? v)
+ (memq (var-definer v) '(define define* lambda lambda*)))
+ (hash-table-ref built-in-functions (car p)))
+ (lint-format "perhaps ~A" caller (lists->string form `(,(car p) ,vvalue)))
+ (if (not (or (any-macro? vname env)
+ (tree-unquoted-member vname (car p))))
+ (lint-format "perhaps, assuming ~A is not a macro, ~A" caller (car p)
+ (lists->string form `(,(car p) ,vvalue)))))))
+
+ (when (pair? (cddr p))
+ (when (and (eq? (car p) 'if)
+ (pair? (cdddr p)))
+
+ (when (and (eq? (cadr p) vname) ; (let ((x (g y))) (if x #t #f)) -> (g y)
+ (boolean? (caddr p))
+ (boolean? (cadddr p))
+ (not (eq? (caddr p) (cadddr p))))
(lint-format "perhaps ~A" caller
- (lists->string form
- (if (null? (cdr body)) ; this only happens in test suites...
- (if (null? (cdr varlist))
- (caddar body)
- `(let ,(map (lambda (v) (if (eq? (car v) (cadar body)) (values) v)) varlist)
- ,(caddar body)))
- `(let ,(map (lambda (v)
- (if (eq? (car v) (cadar body))
- (list (car v) (caddar body))
- v))
- varlist)
- ,@(if (null? (cddr body))
- (cdr body)
- `(,(cadr body) ...))))))
- ;; repetition for the moment
- (when (and (pair? varlist)
- (assq (cadar body) vars) ; settee is a local var
- (not (eq? (cadar body) named-let)) ; (let loop () (set! loop 3))!
- (or (null? (cdr body))
- (and (null? (cddr body))
- (eq? (cadar body) (cadr body))))) ; (let... (set! local val) local)
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (or (tree-memq (cadar body) (caddar body))
- (side-effect? (cadr (assq (cadar body) varlist)) env))
- `(let ,varlist ,(caddar body))
- (if (null? (cdr varlist))
- (caddar body)
- `(let ,(remove-if (lambda (v)
- (eq? (car v) (cadar body)))
- varlist)
- ,(caddar body)))))))))
-
- ;; all let vars are ref'd only in init-vals, no cdr, so substitute
- (when (and (not named-let)
- (pair? body)
- (null? (cdr body))
- (pair? (car body))
- (eq? (caar body) 'do)
- (pair? (cadar body)))
- (let ((inits (map cadr (cadar body))))
- (when (every? (lambda (v)
- (and (= (tree-count1 (car v) (car body) 0) 1)
- (tree-memq (car v) inits)))
- varlist)
- (let ((new-cadr (copy (cadar body))))
- (for-each (lambda (v)
- (set! new-cadr (tree-subst (cadr v) (car v) new-cadr)))
- varlist)
+ (lists->string form (if (caddr p) vvalue `(not ,vvalue)))))
+
+ (when (and (pair? (cadr p)) ; (let ((x (f y))) (if (not x) B (g x))) -> (cond ((f y) => g) (else B))
+ (eq? (caadr p) 'not)
+ (eq? (cadadr p) vname)
+ (pair? (cadddr p))
+ (pair? (cdr (cadddr p)))
+ (null? (cddr (cadddr p)))
+ (eq? vname (cadr (cadddr p))))
+ (let ((else-clause (if (eq? (caddr p) vname)
+ `((else #f))
+ (if (and (pair? (caddr p))
+ (tree-unquoted-member vname (caddr p)))
+ :oops! ; if the let var appears in the else portion, we can't do anything with =>
+ `((else ,(caddr p)))))))
+ (unless (eq? else-clause :oops!)
+ (lint-format "perhaps ~A" caller (lists->string form `(cond (,vvalue => ,(car (cadddr p))) , at else-clause)))))))
+
+ (let ((crf #f))
+ ;; all this stuff still misses (cond ((not x)...)) and (set! y (if x (cdr x)...)) i.e. need embedding in this case
+ (when (and (or (and (memq (car p) '(if and)) ; (let ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f))
+ (eq? (cadr p) vname))
+ (and (eq? (car p) 'or)
+ (equal? (cadr p) `(not ,vname)))
+ (and (pair? vvalue)
+ (memq (car vvalue) '(assoc assv assq member memv memq))
+ (pair? (cadr p))
+ (or (eq? (caadr p) 'pair?)
+ (and (eq? (caadr p) 'null?)
+ (lint-format "in ~A, ~A can't be null because ~A in ~A only returns #f or a pair"
+ caller p vname (car vvalue) (truncated-list->string (car varlist)))
+ #f))
+ (eq? (cadadr p) vname)))
+
+ (or (and (pair? (caddr p))
+ (pair? (cdaddr p))
+ (null? (cddr (caddr p))) ; one func arg
+ (or (eq? vname (cadr (caddr p)))
+ (and (memq (caaddr p) combinable-cxrs)
+ ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f
+ (and cr
+ (< (length cr) 5)
+ (eq? vname arg)
+ (set! crf (symbol "c" cr "r"))))
+ (combine-cxrs (caddr p))))))
+ (and (eq? (car p) 'if)
+ (eq? (caddr p) vname)
+ (not (tree-unquoted-member vname (cdddr p)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cdddr p))
+ vvalue
+ `(or ,vvalue ,(cadddr p)))))
+ #f))
+ (pair? (caddr p))
+ (or (eq? (car p) 'if)
+ (null? (cdddr p))))
+ (let ((else-clause (cond ((pair? (cdddr p))
+ (if (eq? (cadddr p) vname)
+ `((else #f)) ; this stands in for the local var
+ (if (and (pair? (cadddr p))
+ (tree-unquoted-member vname (cadddr p)))
+ :oops! ; if the let var appears in the else portion, we can't do anything with =>
+ `((else ,(cadddr p))))))
+ ((eq? (car p) 'and)
+ `((else #f)))
+ ((eq? (car p) 'or)
+ `((else #t)))
+ (else ()))))
+ (unless (eq? else-clause :oops!)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(cond (,vvalue => ,(or crf (caaddr p))) , at else-clause))))))))
+ )) ; one var in varlist
+
+ ;; (let ((x 1) (y 2)) (+ x y)) -> (+ 1 2)
+ ;; this happens a lot, but it often looks like a form of documentation
+ (when (and (= suggest made-suggestion)
+ (not named-let)
+ (< (length varlist) 8)
+ (not (memq (caar body) '(lambda lambda* define define* define-macro)))
+ (not (and (eq? (caar body) 'set!)
+ (any? (lambda (v) (eq? (car v) (cadar body))) varlist)))
+ (not (any-macro? (caar body) env))
+ (not (any? (lambda (p)
+ (and (pair? p)
+ (not (eq? (car p) 'quote))
+ (or (not (hash-table-ref no-side-effect-functions (car p)))
+ (any? pair? (cdr p)))))
+ (cdar body)))
+ (every? (lambda (v)
+ (and (pair? v)
+ (pair? (cdr v))
+ (< (tree-leaves (cadr v)) 8)
+ (= (tree-count1 (car v) body 0) 1)))
+ varlist))
+ (let ((new-body (copy (car body)))
+ (bool-arg? #f))
+ (for-each (lambda (v)
+ (if (not bool-arg?)
+ (let tree-walk ((tree body))
+ (if (pair? tree)
+ (if (and (memq (car tree) '(or and))
+ (memq (car v) (cdr tree)))
+ (set! bool-arg? #t)
+ (begin
+ (tree-walk (car tree))
+ (tree-walk (cdr tree)))))))
+ (set! new-body (tree-subst (cadr v) (car v) new-body)))
+ varlist)
+ (lint-format (if bool-arg?
+ "perhaps, ignoring short-circuit issues, ~A"
+ "perhaps ~A")
+ caller (lists->string form new-body))))
+ ) ; null cdr body etc
+
+ (when (and (pair? (cadr form)) ; (let ((x x)) (+ x 1)) -> (+ x 1), (let ((x x))...) does not copy x if x is a sequence
+ (= suggest made-suggestion)
+ (every? (lambda (c)
+ (and (pair? c) ; the usual... (let binding might be messed up)
+ (pair? (cdr c))
+ (eq? (car c) (cadr c))))
+ (cadr form))
+ (not (and (pair? (caddr form))
+ (memq (caaddr form) '(lambda lambda*)))))
+ (let ((vs (map car (cadr form))))
+ (unless (any? (lambda (p)
+ (and (pair? p)
+ (memq (cadr p) vs)
+ (or (eq? (car p) 'set!)
+ (set!? p env))))
+ (cddr form))
+ (lint-format "perhaps omit this useless let: ~A" caller
+ (truncated-lists->string form
+ (if (null? (cdddr form))
+ (caddr form)
+ `(begin ,@(cddr form))))))))
+ ) ; suggest let
+
+ (let* ((cur-env (cons (make-var :name :let
+ :initial-value form
+ :definer 'let)
+ (append vars env)))
+ (e (lint-walk-body (or named-let caller) 'let body cur-env)))
+
+ (let ((nvars (and (not (eq? e cur-env))
+ (env-difference caller e cur-env ()))))
+ (if (pair? nvars)
+ (if (eq? (var-name (car nvars)) :lambda)
+ (begin
+ (set! env (cons (car nvars) env))
+ (set! nvars (cdr nvars)))
+ (set! vars (append nvars vars)))))
+
+ (if (and (pair? body)
+ (equal? (list-ref body (- (length body) 1)) '(curlet))) ; the standard library tag
+ (for-each (lambda (v)
+ (set! (var-ref v) (+ (var-ref v) 1)))
+ e))
+
+ (report-usage caller 'let vars cur-env)
+
+ ;; look for let-temporarily possibilities
+ (when (and (pair? vars)
+ (pair? (cadr form))
+ (pair? (caadr form)))
+ (for-each
+ (lambda (local-var)
+ (when (and (zero? (var-set local-var))
+ (= (var-ref local-var) 1)
+ (symbol? (var-initial-value local-var)))
+ (let ((vname (var-name local-var))
+ (saved-name (var-initial-value local-var)))
+ (do ((p body (cdr p))
+ (last-pos #f)
+ (first-pos #f))
+ ((not (pair? p))
+ (when (and (pair? last-pos)
+ (not (eq? first-pos last-pos))
+ (not (tree-member saved-name (cdr last-pos))))
+ (lint-format "perhaps use let-temporarily here (see stuff.scm): ~A" caller
+ (lists->string form
+ (let ((new-let `(let-temporarily
+ ((,saved-name ,(if (pair? first-pos)
+ (caddar first-pos)
+ saved-name)))
+ ,@(map (lambda (expr)
+ (if (or (and (pair? first-pos)
+ (eq? expr (car first-pos)))
+ (eq? expr (car last-pos)))
+ (values)
+ expr))
+ body))))
+ (if (= (length vars) 1)
+ new-let
+ `(let (,@(map (lambda (v)
+ (if (eq? (car v) vname)
+ (values)
+ v))
+ (cadr form)))
+ ,new-let)))))))
+ ;; someday maybe look for additional saved vars, but this happens only in snd-test
+ ;; also the let-temp could be reduced to the set locations (so the tree-member
+ ;; check above would be unneeded).
+ (let ((expr (car p)))
+ (when (and (pair? expr)
+ (eq? (car expr) 'set!)
+ (eq? (cadr expr) saved-name))
+ (if (not first-pos)
+ (set! first-pos p))
+ (if (eq? (caddr expr) vname)
+ (set! last-pos p))))))))
+ vars)))
+
+ (if (and (pair? body) ; (let ((x y)) x) -> y, named let is possible here
+ (null? (cdr body))
+ (pair? varlist) ; (let ()...)
+ (pair? (car varlist)) ; (let (x) ...)
+ (eq? (car body) (caar varlist))
+ (null? (cdr varlist))
+ (pair? (cdar varlist))) ; (let ((a))...)
+ (lint-format "perhaps ~A" caller (lists->string form (cadar varlist))))
+ ;; also (let ((x ...)) (let ((y x)...))) happens but it looks like automatically generated code or test suite junk
+
+ ;; copied from letrec below -- happens about a dozen times
+ (when (and (not named-let)
+ (pair? varlist)
+ (pair? (car varlist))
+ (null? (cdr varlist))
+ (pair? (cddr form))
+ (pair? (caddr form))
+ (null? (cdddr form)))
+ (let ((body (caddr form))
+ (sym (caar varlist))
+ (lform (and (pair? (caadr form))
+ (pair? (cdaadr form))
+ (cadar (cadr form)))))
+ (if (and (pair? lform)
+ (pair? (cdr lform))
+ (eq? (car lform) 'lambda)
+ (proper-list? (cadr lform)))
+ ;; unlike in letrec, here there can't be recursion (ref to same name is ref to outer env)
+ (if (eq? sym (car body))
+ (if (not (tree-memq sym (cdr body)))
(lint-format "perhaps ~A" caller
- (lists->string form `(do ,new-cadr ...)))))))
-
- ;; this is slower in s7 if one step var(?) -- collapse if more than one?
- ;; TODO: what about shadowing?
- (when (and (not named-let)
- (pair? body)
- (pair? (car body))
- (eq? (caar body) 'do)
- (or (null? (cadar body))
- (pair? (cdadar body)))
- (< (tree-leaves (cdr body)) 24)
- (or (null? (caddar body))
- (< (tree-leaves (cdr (caddar body))) 24)))
- (let ((inits (and (pair? (cadar body))
- (map cadr (cadar body)))))
- (unless (and (pair? inits)
- (any? (lambda (v)
- (or (tree-memq (car v) inits)
- (side-effect? (cadr v) env))) ; let var opens *stdin*, do stepper reads it at init
- varlist))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (let ((do-form (car body)))
- (if (null? (cdr body))
- `(do (, at varlist
- ,@(cadr do-form))
- ...)
- `(do (, at varlist
- ,@(cadr do-form))
- (,(and (pair? (caddr do-form)) (caaddr do-form))
- ,@(if (side-effect? (cdr (caddr do-form)) env) (cdr (caddr do-form)) ())
- ,@(cdr body))
- ...))))))))
- (when (and (not named-let)
- (pair? varlist)
- (> (length body) 3)
- (every? pair? varlist)
- (not (tree-set-car-member '(define define* define-macro define-macro*
- define-bacro define-bacro* define-constant define-expansion)
- body)))
- ;; define et al are like a continuation of the let bindings, so we can't restrict them by accident
- ;; (let ((x 1)) (define y x) ...)
- (let ((last-refs (map (lambda (v) (vector (var-name v) #f 0 v)) vars))
- (got-lambdas (tree-set-car-member '(lambda lambda*) body)))
- ;; (let ((x #f) (y #t)) (set! x (lambda () y)) (set! y 5) (x))
- (do ((p body (cdr p))
- (i 0 (+ i 1)))
- ((null? p)
- (let ((end 0)
- (len i))
+ (lists->string
+ form `(let ,(map list (cadr lform) (cdr body))
+ ,@(cddr lform)))))
+ (if (= (tree-count1 sym body 0) 1)
+ (let ((call (find-call sym body)))
+ (when (pair? call)
+ (let ((new-call `(let ,(map list (cadr lform) (cdr call))
+ ,@(cddr lform))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst new-call call body)))))))))))
+
+ (when (and (pair? body)
+ (pair? (car body))
+ (pair? (cdar body))
+ (pair? (cddar body))
+ (eq? (caar body) 'set!))
+ (let ((settee (cadar body))
+ (setval (caddar body)))
+ (if (and (not named-let) ; (let ((x 0)...) (set! x 1)...) -> (let ((x 1)...)...)
+ (not (tree-memq 'curlet setval))
+ (cond ((assq settee vars)
+ => (lambda (v)
+ (or (and (code-constant? (var-initial-value v))
+ (code-constant? setval))
+ (not (any? (lambda (v1)
+ (or (tree-memq (car v1) setval)
+ (side-effect? (cadr v1) env)))
+ varlist)))))
+ (else #f)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (null? (cdr body)) ; this only happens in test suites...
+ (if (null? (cdr varlist))
+ setval
+ `(let ,(map (lambda (v) (if (eq? (car v) settee) (values) v)) varlist)
+ ,setval))
+ `(let ,(map (lambda (v)
+ (if (eq? (car v) settee)
+ (list (car v) setval)
+ v))
+ varlist)
+ ,@(if (null? (cddr body))
+ (cdr body)
+ `(,(cadr body) ...))))))
+ ;; repetition for the moment
+ (when (and (pair? varlist)
+ (assq settee vars) ; settee is a local var
+ (not (eq? settee named-let)) ; (let loop () (set! loop 3))!
+ (or (null? (cdr body))
+ (and (null? (cddr body))
+ (eq? settee (cadr body))))) ; (let... (set! local val) local)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (or (tree-memq settee setval)
+ (side-effect? (cadr (assq settee varlist)) env))
+ `(let ,varlist ,setval)
+ (if (null? (cdr varlist))
+ setval
+ `(let ,(remove-if (lambda (v)
+ (eq? (car v) settee))
+ varlist)
+ ,setval)))))))))
+ (when (and (not named-let)
+ (pair? body))
+
+ ;; if var val is symbol, val not used (not set!) in body (even hidden via function call)
+ ;; and var not set!, and not a function parameter (we already reported those), and
+ ;; we're not saving some global locally for a function about-to-be exported,
+ ;; remove it (the var) and replace with val throughout
+ (when (and (proper-list? (cadr form))
+ (not (tree-set-member '(lambda lambda*) body)))
+ (let ((changes ()))
+ (do ((vs (cadr form) (cdr vs)))
+ ((null? vs)
+ (if (pair? changes)
+ (let ((new-form (copy form)))
+ (for-each
+ (lambda (v)
+ (list-set! new-form 1 (remove-if (lambda (p) (equal? p v)) (cadr new-form)))
+ (set! new-form (tree-subst (cadr v) (car v) new-form)))
+ changes)
+ (lint-format "assuming we see all set!s, ~{~A~^, ~} ~A pointless: perhaps ~A" caller
+ changes
+ (if (pair? (cdr changes)) "are" "is")
+ (lists->string form new-form)))))
+ (let ((v (car vs)))
+ (if (and (pair? v)
+ (pair? (cdr v))
+ (null? (cddr v)) ; good grief
+ (symbol? (cadr v))
+ (not (eq? (car v) (cadr v))) ; this is handled elsewhere
+ (not (set-target (cadr v) body env))
+ (not (set-target (car v) body env))
+ (let ((data (var-member (cadr v) env)))
+ (or (not (var? data))
+ (and (not (eq? (var-definer data) 'parameter))
+ (or (null? (var-setters data))
+ (not (tree-set-member (var-setters data) body)))))))
+ (set! changes (cons v changes)))))))
+
+
+ ;; if last is (set! local-var...) and no complications, complain
+ (let ((last (list-ref body (- (length body) 1))))
+ (if (and (pair? last)
+ (eq? (car last) 'set!)
+ (pair? (cdr last))
+ (pair? (cddr last)) ; (set! a)
+ (symbol? (cadr last))
+ (assq (cadr last) varlist)
+ (not (tree-set-member '(call/cc call-with-current-continuation curlet lambda lambda*) form)))
+ (lint-format "set! is pointless in ~A: use ~A" caller
+ last (caddr last))))
+
+ ;; all let vars are ref'd only in init-vals, no cdr, so substitute
+ (when (and (null? (cdr body))
+ (pair? (car body))
+ (eq? (caar body) 'do)
+ (pair? (cadar body)))
+ (let ((inits (map cadr (cadar body))))
+ (when (every? (lambda (v)
+ (and (= (tree-count1 (car v) (car body) 0) 1)
+ (tree-memq (car v) inits)))
+ varlist)
+ (let ((new-cadr (copy (cadar body))))
+ (for-each (lambda (v)
+ (set! new-cadr (tree-subst (cadr v) (car v) new-cadr)))
+ varlist)
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(do ,new-cadr ...)))))))
+
+ ;; this is slower in s7 if one step var(?) -- collapse if more than one?
+ ;; TODO: what about shadowing?
+ (when (and (pair? (car body))
+ (eq? (caar body) 'do)
+ (or (null? (cadar body))
+ (pair? (cdadar body)))
+ (< (tree-leaves (cdr body)) 24)
+ (or (null? (caddar body))
+ (< (tree-leaves (cdr (caddar body))) 24)))
+ (let ((inits (and (pair? (cadar body))
+ (map cadr (cadar body)))))
+ (unless (and (pair? inits)
+ (any? (lambda (v)
+ (or (tree-memq (car v) inits)
+ (side-effect? (cadr v) env))) ; let var opens *stdin*, do stepper reads it at init
+ varlist))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (let ((do-form (car body)))
+ (if (null? (cdr body))
+ `(do (, at varlist
+ ,@(cadr do-form))
+ ...)
+ `(do (, at varlist
+ ,@(cadr do-form))
+ (,(and (pair? (caddr do-form)) (caaddr do-form))
+ ,@(if (side-effect? (cdr (caddr do-form)) env) (cdr (caddr do-form)) ())
+ ,@(cdr body))
+ ...))))))))
+ (when (and (pair? varlist)
+ (> (length body) 3)
+ (every? pair? varlist)
+ (not (tree-set-car-member '(define define* define-macro define-macro*
+ define-bacro define-bacro* define-constant define-expansion)
+ body)))
+ ;; define et al are like a continuation of the let bindings, so we can't restrict them by accident
+ ;; (let ((x 1)) (define y x) ...)
+ (let ((last-refs (map (lambda (v) (vector (var-name v) #f 0 v)) vars))
+ (got-lambdas (tree-set-car-member '(lambda lambda*) body)))
+ ;; (let ((x #f) (y #t)) (set! x (lambda () y)) (set! y 5) (x))
+ (do ((p body (cdr p))
+ (i 0 (+ i 1)))
+ ((null? p)
+ (let ((end 0))
+ (for-each (lambda (v)
+ (set! end (max end (v 2))))
+ last-refs)
+ (if (and (< end (/ i lint-let-reduction-factor))
+ (eq? form lint-current-form)
+ (< (tree-leaves (car body)) 100))
+ (let ((old-start (let ((old-pp ((funclet 'lint-pretty-print) '*pretty-print-left-margin*)))
+ (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) (+ lint-left-margin 4))
+ (let ((res (lint-pp `(let ,(cadr form)
+ ,@(copy body (make-list (+ end 1)))))))
+ (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) old-pp)
+ res))))
+ (lint-format "this let could be tightened:~%~NC~A ->~%~NC~A~%~NC~A ..." caller
+ (+ lint-left-margin 4) #\space
+ (truncated-list->string form)
+ (+ lint-left-margin 4) #\space
+ old-start
+ (+ lint-left-margin 4) #\space
+ (lint-pp (list-ref body (+ end 1)))))
+
+ (let ((mnv ())
+ (cur-end i))
(for-each (lambda (v)
- (set! end (max end (v 2))))
+ (when (and (or (null? mnv)
+ (<= (v 2) cur-end))
+ (positive? (var-ref (v 3)))
+ (let ((expr (var-initial-value (v 3))))
+ (not (any? (lambda (ov) ; watch out for shadowed vars
+ (tree-memq (car ov) expr))
+ varlist))))
+ (set! mnv (if (= (v 2) cur-end)
+ (cons v mnv)
+ (list v)))
+ (set! cur-end (v 2))))
last-refs)
- (if (and (< end (/ len lint-let-reduction-factor))
- (eq? form lint-current-form)
- (< (tree-leaves (car body)) 100))
- (lint-format "this let could be tightened:~%~NC~A ->~%~NC~A~%~NC~A ..." caller
- (+ lint-left-margin 4) #\space
- (truncated-list->string form)
- (+ lint-left-margin 4) #\space
- (let ((old-pp ((funclet 'lint-pretty-print) '*pretty-print-left-margin*)))
- (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) (+ lint-left-margin 4))
- (let ((res (lint-pp `(let ,(cadr form)
- ,@(copy body (make-list (+ end 1)))))))
- (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) old-pp)
- res))
- (+ lint-left-margin 4) #\space
- (lint-pp (list-ref body (+ end 1))))
-
- (let ((mnv ())
- (cur-end len))
- (for-each (lambda (v)
- (when (and (or (null? mnv)
- (<= (v 2) cur-end))
- (positive? (var-ref (v 3)))
- (let ((expr (var-initial-value (v 3))))
- (not (any? (lambda (ov) ; watch out for shadowed vars
- (tree-memq (car ov) expr))
- varlist))))
- (set! mnv (if (= (v 2) cur-end)
- (cons v mnv)
- (list v)))
- (set! cur-end (v 2))))
- last-refs)
- (when (and (pair? mnv)
- (< cur-end (/ len lint-let-reduction-factor))
- (> (- len cur-end) 3))
- ;; mnv is in the right order because last-refs is reversed
- (lint-format "the scope of ~{~A~^, ~} could be reduced: ~A" caller
- (map (lambda (v) (v 0)) mnv)
- (lists->string form
- `(let ,(map (lambda (v)
- (if (member (car v) mnv (lambda (a b) (eq? a (b 0))))
- (values)
- v))
- varlist)
- (let ,(map (lambda (v)
- (list (v 0) (var-initial-value (v 3))))
- mnv)
- ,@(copy body (make-list (+ cur-end 1))))
- ,(list-ref body (+ cur-end 1))
- ...))))))))
- (if (and (not got-lambdas)
- (pair? (car p))
- (pair? (cdr p))
- (eq? (caar p) 'set!)
- (var-member (cadar p) vars)
- (not (tree-memq (cadar p) (cdr p))))
- (if (not (side-effect? (caddar p) env))
- (lint-format "~A in ~A could be omitted" caller (car p) (truncated-list->string form))
- (lint-format "perhaps ~A" caller (lists->string (car p) (caddar p)))))
-
- (for-each (lambda (v)
- (when (tree-memq (v 0) (car p))
- (set! (v 2) i)
- (if (not (v 1)) (set! (v 1) i))))
- last-refs))))
+ (when (and (pair? mnv)
+ (< cur-end (/ i lint-let-reduction-factor))
+ (> (- i cur-end) 3))
+ ;; mnv is in the right order because last-refs is reversed
+ (lint-format "the scope of ~{~A~^, ~} could be reduced: ~A" caller
+ (map (lambda (v) (v 0)) mnv)
+ (lists->string form
+ `(let ,(map (lambda (v)
+ (if (member (car v) mnv (lambda (a b) (eq? a (b 0))))
+ (values)
+ v))
+ varlist)
+ (let ,(map (lambda (v)
+ (list (v 0) (var-initial-value (v 3))))
+ mnv)
+ ,@(copy body (make-list (+ cur-end 1))))
+ ,(list-ref body (+ cur-end 1))
+ ...))))))))
+ (if (and (not got-lambdas)
+ (pair? (car p))
+ (pair? (cdr p))
+ (eq? (caar p) 'set!)
+ (var-member (cadar p) vars)
+ (not (tree-memq (cadar p) (cdr p))))
+ (if (not (side-effect? (caddar p) env))
+ (lint-format "~A in ~A could be omitted" caller (car p) (truncated-list->string form))
+ (lint-format "perhaps ~A" caller (lists->string (car p) (caddar p)))))
- ;; out of place and repetitive code...
- (when (and (pair? (cadr form))
- (pair? (cddr form))
- (null? (cdddr form))
- (pair? (caddr form)))
- (let ((inner (caddr form)))
- (when (and (eq? (car inner) 'let)
- (pair? (cdr inner))
- (symbol? (cadr inner)))
- (let ((named-body (cdddr inner))
- (named-args (caddr inner)))
- (unless (any? (lambda (v) ; TODO: here and elsewhere -- no definers in the cadrs, and only one side-effect?
- (or (not (= (tree-count1 (car v) named-args 0) 1))
- (tree-memq (car v) named-body)))
- varlist)
- (let ((new-args (copy named-args)))
- (for-each (lambda (v)
- (set! new-args (tree-subst (cadr v) (car v) new-args)))
- varlist)
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let ,(cadr inner) ,new-args , at named-body)))))))))
-
- ;; maybe more code than this is worth -- combine lets
- (when (and (pair? (cadr form))
- (pair? (cddr form))
- (null? (cdddr form))
- (pair? (caddr form))
- (memq (caaddr form) '(let let*))
- (pair? (cdr (caddr form)))
- (pair? (cadr (caddr form))))
- (let ((inner (caddr form)))
-
- (define (letstar . lets)
- (let loop ((vars (list 'curlet)) (forms lets))
- (and (pair? forms)
- (or (and (pair? (car forms))
- (or (tree-set-member vars (car forms))
- (any? (lambda (a)
- (or (not (pair? a))
- (not (pair? (cdr a)))
- (side-effect? (cadr a) env)))
- (car forms))))
- (loop (append (map car (car forms)) vars)
- (cdr forms))))))
+ (for-each (lambda (v)
+ (when (tree-memq (v 0) (car p))
+ (set! (v 2) i)
+ (if (not (v 1)) (set! (v 1) i))))
+ last-refs)))))
+
+ ;; out of place and repetitive code...
+ (when (and (pair? (cadr form))
+ (pair? (cddr form))
+ (null? (cdddr form))
+ (pair? (caddr form)))
+ (let ((inner (caddr form)))
+
+ (when (and (eq? (car inner) 'let)
+ (pair? (cdr inner))
+ (symbol? (cadr inner)))
+ (let ((named-body (cdddr inner))
+ (named-args (caddr inner)))
+ (unless (any? (lambda (v)
+ (or (not (= (tree-count1 (car v) named-args 0) 1))
+ (tree-memq (car v) named-body)))
+ varlist)
+ (let ((new-args (copy named-args)))
+ (for-each (lambda (v)
+ (set! new-args (tree-subst (cadr v) (car v) new-args)))
+ varlist)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let ,(cadr inner) ,new-args , at named-body)))))))
+
+ ;; maybe more code than this is worth -- combine lets
+ (when (and (memq (caaddr form) '(let let*))
+ (pair? (cdr (caddr form)))
+ (pair? (cadr (caddr form))))
+
+ (define (letstar . lets)
+ (let loop ((vars (list 'curlet)) (forms lets))
+ (and (pair? forms)
+ (or (and (pair? (car forms))
+ (or (tree-set-member vars (car forms))
+ (any? (lambda (a)
+ (or (not (pair? a))
+ (not (pair? (cdr a)))
+ (side-effect? (cadr a) env)))
+ (car forms))))
+ (loop (append (map car (car forms)) vars)
+ (cdr forms))))))
+
+ (cond ((and (null? (cdadr form)) ; let(1) + let* -> let*
+ (eq? (car inner) 'let*)
+ (not (symbol? (cadr inner)))) ; not named let*
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let* (,@(cadr form)
+ ,@(cadr inner))
+ ,@(one-call-and-dots (cddr inner))))))
+ ((and (pair? (cddr inner))
+ (pair? (caddr inner))
+ (null? (cdddr inner))
+ (eq? (caaddr inner) 'let)
+ (pair? (cdr (caddr inner)))
+ (pair? (cadr (caddr inner))))
+ (let ((inner1 (caddr inner)))
+ (if (and (pair? (cddr inner1))
+ (null? (cdddr inner1))
+ (pair? (caddr inner1))
+ (eq? (caaddr inner1) 'let)
+ (pair? (cdr (caddr inner1)))
+ (pair? (cadr (caddr inner1))))
+ (let ((inner2 (caddr inner1)))
+ (if (not (letstar (cadr form)
+ (cadr inner)
+ (cadr inner1)
+ (cadr inner2)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let (,@(cadr form)
+ ,@(cadr inner)
+ ,@(cadr inner1)
+ ,@(cadr inner2))
+ ,@(one-call-and-dots (cddr inner2)))))))
+ (if (not (letstar (cadr form)
+ (cadr inner)
+ (cadr inner1)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let (,@(cadr form)
+ ,@(cadr inner)
+ ,@(cadr inner1))
+ ,@(one-call-and-dots (cddr inner1)))))))))
+ ((not (letstar (cadr form)
+ (cadr inner)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let (,@(cadr form)
+ ,@(cadr inner))
+ ,@(one-call-and-dots (cddr inner))))))
- (cond ((and (null? (cdadr form)) ; let(1) + let* -> let*
- (eq? (car inner) 'let*)
- (not (symbol? (cadr inner)))) ; not named let*
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let* (,@(cadr form)
- ,@(cadr inner))
- ,@(one-call-and-dots (cddr inner))))))
- ((and (pair? (cddr inner))
- (pair? (caddr inner))
- (null? (cdddr inner))
- (eq? (caaddr inner) 'let)
- (pair? (cdr (caddr inner)))
- (pair? (cadr (caddr inner))))
- (let ((inner1 (caddr inner)))
- (if (and (pair? (cddr inner1))
- (null? (cdddr inner1))
- (pair? (caddr inner1))
- (eq? (caaddr inner1) 'let)
- (pair? (cdr (caddr inner1)))
- (pair? (cadr (caddr inner1))))
- (let ((inner2 (caddr inner1)))
- (if (not (letstar (cadr form)
- (cadr inner)
- (cadr inner1)
- (cadr inner2)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let (,@(cadr form)
- ,@(cadr inner)
- ,@(cadr inner1)
- ,@(cadr inner2))
- ,@(one-call-and-dots (cddr inner2)))))))
- (if (not (letstar (cadr form)
- (cadr inner)
- (cadr inner1)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let (,@(cadr form)
- ,@(cadr inner)
- ,@(cadr inner1))
- ,@(one-call-and-dots (cddr inner1)))))))))
- ((not (letstar (cadr form)
- (cadr inner)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let (,@(cadr form)
- ,@(cadr inner))
- ,@(one-call-and-dots (cddr inner))))))
-
- ((and (null? (cdadr form)) ; 1 outer var
- (pair? (cadr inner))
- (null? (cdadr inner))) ; 1 inner var, dependent on outer
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let* (,@(cadr form)
- ,@(cadr inner))
- ,@(one-call-and-dots (cddr inner)))))))))
+ ((and (null? (cdadr form)) ; 1 outer var
+ (pair? (cadr inner))
+ (null? (cdadr inner))) ; 1 inner var, dependent on outer
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let* (,@(cadr form)
+ ,@(cadr inner))
+ ,@(one-call-and-dots (cddr inner))))))))))
+ ))) ; messed up let
+ env)
+ (hash-table-set! h 'let let-walker))
+
+ ;; ---------------- let* ----------------
+ (let ()
+ (define (let*-walker caller form env)
+ (if (< (length form) 3)
+ (lint-format "let* is messed up: ~A" caller (truncated-list->string form))
+ (let ((named-let (and (symbol? (cadr form)) (cadr form))))
+
+ (let ((vars (if named-let (list (make-var :name named-let
+ :definer 'let*)) ())) ; TODO: fvar
+ (varlist ((if named-let caddr cadr) form))
+ (body ((if named-let cdddr cddr) form)))
+ (if (not (list? varlist))
+ (lint-format "let* is messed up: ~A" caller (truncated-list->string form)))
+
+ (let ((side-effects #f))
+ (do ((bindings varlist (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "let* variable list is not a proper list? ~S"
+ caller ((if named-let caddr cadr) form))))
+ (when (binding-ok? caller 'let* (car bindings) env #f)
+ (let ((expr (cadar bindings))
+ (side (side-effect? (cadar bindings) env)))
+ (if (not (or (eq? bindings varlist)
+ ;; first var side-effect is innocuous (especially if it's the only one!)
+ ;; does this need to protect against a side-effect that the next var accesses?
+ ;; I think we're ok -- the accessed var must be exterior, and we go down in order
+ side-effects))
+ (set! side-effects side))
+ (lint-walk caller expr (append vars env))
+ (set! vars (cons (make-var :name (caar bindings)
+ :initial-value expr
+ :definer (if named-let 'named-let* 'let*))
+ vars))
- ))) ; messed up let
- env)
-
- ;; ---------------- let* ----------------
- ((let*)
- (if (< (length form) 3)
- (lint-format "let* is messed up: ~A" caller (truncated-list->string form))
- (let ((named-let (and (symbol? (cadr form)) (cadr form))))
-
- (let ((vars (if named-let (list (make-var :name named-let
- :definer 'let*)) ())) ; TODO: fvar
- (varlist (if named-let (caddr form) (cadr form)))
- (body (if named-let (cdddr form) (cddr form))))
- (if (not (list? varlist))
- (lint-format "let* is messed up: ~A" caller (truncated-list->string form)))
-
- (let ((side-effects #f))
- (do ((bindings varlist (cdr bindings)))
- ((not (pair? bindings))
- (if (not (null? bindings))
- (lint-format "let* variable list is not a proper list? ~S"
- caller (if named-let (caddr form) (cadr form)))))
- (when (binding-ok? caller head (car bindings) env #f)
- (let ((expr (cadar bindings))
- (side (side-effect? (cadar bindings) env)))
- (if (not (or (eq? bindings varlist)
- ;; first var side-effect is innocuous (especially if it's the only one!)
- ;; does this need to protect against a side-effect that the next var accesses?
- ;; I think we're ok -- the accessed var must be exterior, and we go down in order
- side-effects))
- (set! side-effects side))
- (lint-walk caller expr (append vars env))
- (set! vars (cons (make-var :name (caar bindings)
- :initial-value expr
- :definer (if named-let 'named-let* 'let*))
- vars))
- ;; look for duplicate values
-
- ;; TODO: protect against any shadows if included in any expr
-
- (if (and (pair? expr)
- (not (code-constant? expr))
- (not (maker? expr))
- (not side))
- (let ((name (caar bindings)))
- (let dup-check ((vs (cdr vars)))
- (if (and (pair? vs)
- (pair? (car vs))
- (not (eq? name (caar vs)))
- (not (tree-memq (caar vs) expr)))
- ;; perhaps also not side-effect of car vs initial-value (char-ready? + read + char-ready? again)
- (if (equal? expr (var-initial-value (car vs)))
- (lint-format "~A's value ~A could be ~A" caller
- name expr (caar vs))
- (dup-check (cdr vs))))))))))
-
- (if (not (or side-effects
- (any? (lambda (v) (positive? (var-ref v))) vars)))
- (lint-format "let* could be let: ~A" caller (truncated-list->string form))))
- ;; in s7, let evaluates var values top down, so this message is correct
- ;; even in cases like (let ((ind (open-sound...)) (mx (maxamp))) ...)
- ;; in r7rs, the order is not specified (section 4.2.2 of the spec), so
- ;; here we would restrict this message to cases where there is only
- ;; one variable, or where subsequent values are known to be independent.
- ;; if each function could tell us what globals it depends on or affects,
- ;; we could make this work in all cases.
+ ;; look for duplicate values
+ ;; TODO: protect against any shadows if included in any expr
+ (if (and (pair? expr)
+ (not (code-constant? expr))
+ (not (maker? expr))
+ (not side))
+ (let ((name (caar bindings)))
+ (let dup-check ((vs (cdr vars)))
+ (if (and (pair? vs)
+ (pair? (car vs))
+ (not (eq? name (caar vs)))
+ (not (tree-memq (caar vs) expr)))
+ ;; perhaps also not side-effect of car vs initial-value (char-ready? + read + char-ready? again)
+ (if (equal? expr (var-initial-value (car vs)))
+ (lint-format "~A's value ~A could be ~A" caller
+ name expr (caar vs))
+ (dup-check (cdr vs))))))))))
+
+ (if (not (or side-effects
+ (any? (lambda (v) (positive? (var-ref v))) vars)))
+ (lint-format "let* could be let: ~A" caller (truncated-list->string form))))
+ ;; in s7, let evaluates var values top down, so this message is correct
+ ;; even in cases like (let ((ind (open-sound...)) (mx (maxamp))) ...)
+ ;; in r7rs, the order is not specified (section 4.2.2 of the spec), so
+ ;; here we would restrict this message to cases where there is only
+ ;; one variable, or where subsequent values are known to be independent.
+ ;; if each function could tell us what globals it depends on or affects,
+ ;; we could make this work in all cases.
+
+ (let* ((cur-env (cons (make-var :name :let
+ :initial-value form
+ :definer 'let*)
+ (append vars env)))
+ (e (lint-walk-body caller 'let* body cur-env)))
+
+ (let ((nvars (and (not (eq? e cur-env))
+ (env-difference caller e cur-env ()))))
+ (if (pair? nvars)
+ (if (eq? (var-name (car nvars)) :lambda)
+ (begin
+ (set! env (cons (car nvars) env))
+ (set! nvars (cdr nvars)))
+ (set! vars (append nvars vars)))))
+
+ (report-usage caller 'let* vars cur-env))
+
+
+ (when (and (not named-let)
+ (pair? body)
+ (pair? varlist)) ; from here to end
+
+ ;; (let*->let*) combined into one
+ (when (and (pair? (car body))
+ (or (eq? (caar body) 'let*) ; let*+let* -> let*
+ (and (eq? (caar body) 'let) ; let*+let(1) -> let*
+ (or (null? (cadar body))
+ (and (pair? (cadar body))
+ (null? (cdadar body))))))
+ (null? (cdddr form))
+ (not (symbol? (cadar body))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(let* (, at varlist
+ ,@(cadar body))
+ ,@(one-call-and-dots (cddar body))))))
+
+ (when (and (proper-list? (cadr form))
+ (not (tree-set-member '(lambda lambda*) body)))
+ ;; see let above
+ (let ((changes ()))
+ (do ((vs (cadr form) (cdr vs)))
+ ((null? vs)
+ (if (pair? changes)
+ (let ((new-form (copy form)))
+ (for-each
+ (lambda (v)
+ (list-set! new-form 1 (remove-if (lambda (p) (equal? p v)) (cadr new-form)))
+ (set! new-form (tree-subst (cadr v) (car v) new-form)))
+ changes)
+ (lint-format "assuming we see all set!s, ~{~A~^, ~} ~A pointless: perhaps ~A" caller
+ changes
+ (if (pair? (cdr changes)) "are" "is")
+ (lists->string form
+ `(,(if (and (pair? (cadr new-form))
+ (pair? (cdadr new-form)))
+ 'let* 'let)
+ ,@(cdr new-form)))))))
+ (let ((v (car vs)))
+ (if (and (pair? v)
+ (pair? (cdr v))
+ (null? (cddr v)) ; good grief
+ (symbol? (cadr v))
+ (not (eq? (car v) (cadr v))) ; this is handled elsewhere
+ (not (assq (cadr v) (cadr form))) ; value is not a local var
+ (not (set-target (car v) body env))
+ (not (set-target (cadr v) body env)))
+ (let ((data (var-member (cadr v) env)))
+ (if (and (or (not (var? data))
+ (and (not (eq? (var-definer data) 'parameter))
+ (or (null? (var-setters data))
+ (not (tree-set-member (var-setters data) body)))))
+ (not (any? (lambda (p)
+ (and (pair? p)
+ (pair? (cdr p))
+ (or (set-target (cadr v) (cdr p) env)
+ (set-target (car v) (cdr p) env)
+ (and (var? data)
+ (pair? (var-setters data))
+ (tree-set-member (var-setters data) body)))))
+ (cdr vs))))
+ (set! changes (cons v changes)))))))))
+
+ (let* ((varlist-len (length varlist))
+ (last-var (and (positive? varlist-len)
+ (list-ref varlist (- varlist-len 1))))) ; from here to end
+ (when (pair? last-var) ; successive vars, first used in second but nowhere else -- combine if (very!) simple-looking
+ (do ((gone-vars ())
+ (v varlist (cdr v)))
+ ((or (null? v)
+ (null? (cdr v)))
+
+ (when (pair? gone-vars)
+ (let ((waiter #f)
+ (new-vars ())
+ (save-vars ()))
+ (set! gone-vars (reverse gone-vars))
+ (set! new-vars (map (lambda (v)
+ (if (and (pair? gone-vars)
+ (eq? v (car gone-vars)))
+ (begin
+ (set! waiter v)
+ (set! gone-vars (cdr gone-vars))
+ (values))
+ (if (not waiter)
+ v
+ (let ((new-v (tree-subst (cadr waiter) (car waiter) v)))
+ (set! save-vars (cons (list (car waiter) (car v)) save-vars))
+ (set! waiter #f)
+ new-v))))
+ varlist))
+ (lint-format "perhaps substitute ~{~{~A into ~A~}~^, ~}: ~A" caller
+ (reverse save-vars)
+ (lists->string form
+ `(,(if (null? (cdr new-vars)) 'let 'let*)
+ ,new-vars
+ ...))))))
+ (let ((cur-var (car v))
+ (nxt-var (cadr v)))
+ (when (and (pair? cur-var)
+ (pair? nxt-var)
+ (pair? (cdr cur-var))
+ (pair? (cdr nxt-var))
+ (< (tree-leaves (cadr cur-var)) 8)
+ (not (and (pair? (cadr nxt-var))
+ (eq? (caadr nxt-var) 'let) ; if named-let, forget it
+ (pair? (cdadr nxt-var))
+ (symbol? (cadadr nxt-var))))
+ (or (not (pair? (cadr nxt-var)))
+ (not (side-effect? (cadr cur-var) env))
+ (every? (lambda (a)
+ (or (code-constant? a)
+ (assq a varlist)))
+ (cdadr nxt-var)))
+ (= (tree-count1 (car cur-var) (cadr nxt-var) 0) 1)
+ (not (tree-memq (car cur-var) (cddr v)))
+ (not (tree-memq (car cur-var) body)))
+ (set! gone-vars (cons cur-var gone-vars))
+ (set! v (cdr v)))))
+
+ ;; if last var only occurs once in body, and timing can't be an issue, substitute its value
+ ;; this largely copied from the let case above (but only one substitution)
+ ;; in both cases, we're assuming that the possible last-var value's side-effect won't
+ ;; affect other vars (in let* the local, in let something outside that might be used locally)
+ ;; perhaps add (not (side-effect (cadr last-var) env))?
+
+ (when (and (pair? (cdr last-var)) ; varlist-len can be 1 here
+ (< (tree-leaves (cadr last-var)) 12)
+ (= (tree-count1 (car last-var) body 0) 1)
+ (pair? (car body))
+ (null? (cdr body))
+ (not (memq (caar body) '(lambda lambda* define define* define-macro)))
+ (not (and (eq? (caar body) 'set!)
+ (eq? (car last-var) (cadar body))))
+ (not (any-macro? (caar body) env))
+ (not (any? (lambda (p)
+ (and (pair? p)
+ (not (eq? (car p) 'quote))
+ (or (not (hash-table-ref no-side-effect-functions (car p)))
+ (any? pair? (cdr p)))))
+ (cdar body))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form `(,(if (<= varlist-len 2) 'let 'let*)
+ ,(copy varlist (make-list (- varlist-len 1)))
+ ,@(tree-subst (cadr last-var) (car last-var) body)))))
+
+ (when (null? (cdr body)) ; (let* (...(x A)) (if x (f A) B)) -> (let(*) (...) (cond (A => f) (else B)))
- (let* ((cur-env (append vars env))
- (e (lint-walk-body caller head body cur-env))
- (nvars (and (not (eq? e cur-env))
- (env-difference caller e cur-env ()))))
- (if (pair? nvars)
- (if (eq? (var-name (car nvars)) :lambda)
- (begin
- (set! env (cons (car nvars) env))
- (set! nvars (cdr nvars)))
- (set! vars (append nvars vars))))
+ (when (pair? (cdr last-var))
+ (let ((p (car body)))
+ (when (and (pair? p)
+ (pair? (cdr p))
+ (case (car p)
+ ((if and) (eq? (cadr p) (car last-var)))
+ ((or) (equal? (cadr p) `(not ,(car last-var))))
+ (else #f))
+ (pair? (cddr p))
+ (pair? (caddr p))
+ (or (eq? (car p) 'if)
+ (null? (cdddr p)))
+ (pair? (cdaddr p))
+ (not (eq? (caaddr p) (car last-var))) ; ! (let* (...(x A)) (if x (x x)))
+ (null? (cddr (caddr p)))
+ (eq? (car last-var) (cadr (caddr p))))
+
+ (let ((else-clause (cond ((pair? (cdddr p)) ; only if 'if (see above)
+ (if (eq? (cadddr p) (car last-var))
+ `((else #f)) ; this stands in for the local var
+ (if (and (pair? (cadddr p))
+ (tree-unquoted-member (car last-var) (cadddr p)))
+ :oops! ; if the let var appears in the else portion, we can't do anything with =>
+ `((else ,(cadddr p))))))
+ ((eq? (car p) 'and)
+ `((else #f)))
+ ((eq? (car p) 'or)
+ `((else #t)))
+ (else ()))))
+ (if (not (eq? else-clause :oops!))
+ (lint-format "perhaps ~A" caller
+ (case varlist-len
+ ((1) (lists->string form
+ `(cond (,(cadr last-var) => ,(caaddr p)) , at else-clause)))
+ ((2) (lists->string form
+ `(let (,(car varlist))
+ (cond (,(cadr last-var) => ,(caaddr p)) , at else-clause))))
+ (else (lists->string form
+ `(let* (,@(copy varlist (make-list (- varlist-len 1))))
+ (cond (,(cadr last-var) => ,(caaddr p)) , at else-clause)))))))))))
- (report-usage caller head vars cur-env))
-
- (unless named-let
- ;; look for exprs replaceable with vars
- (find-let-constant-exprs caller form vars body)
-
- ;; (let*->let*) combined into one
- (if (and (pair? body)
- (pair? (car body))
- (or (eq? (caar body) 'let*) ; let*+let* -> let*
- (and (eq? (caar body) 'let) ; let*+let(1) -> let*
- (or (null? (cadar body))
- (and (pair? (cadar body))
- (null? (cdadar body))))))
- (null? (cdddr form))
- (not (symbol? (cadar body))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(let* (, at varlist
- ,@(cadar body))
- ,@(one-call-and-dots (cddar body))))))
-
- ;; if last var only occurs once in body, and timing can't be an issue, substitute its value
- ;; this largely copied from the let case above (but only one substitution)
- ;; in both cases, we're assuming that the possible last-var value's side-effect won't
- ;; affect other vars (in let* the local, in let something outside that might be used locally)
- ;; perhaps add (not (side-effect (cadr last-var) env))?
- (when (pair? varlist)
- (let* ((len (length varlist))
- (last-var (and (positive? len)
- (list-ref varlist (- len 1)))))
- (if (and (> len 1)
+ (when (and (pair? (car varlist)) ; same as let: (let* ((x y)) x) -> y -- (let* (x) ...)
+ (not (pair? (car body))))
+ (if (and (eq? (car body) (caar varlist))
+ (null? (cdr varlist))
+ (pair? (cdar varlist))) ; (let* ((a...)) a)
+ (lint-format "perhaps ~A" caller (lists->string form (cadar varlist)))
+ (if (and (> varlist-len 1) ; (let* (... (x y)) x) -> (let(*)(...) y)
(pair? last-var)
(pair? (cdr last-var))
- (< (tree-leaves (cadr last-var)) 12)
- (= (tree-count1 (car last-var) body 0) 1)
- (pair? body)
- (pair? (car body))
- (null? (cdr body))
- (not (memq (caar body) '(lambda lambda* define define* define-macro)))
- (not (and (eq? (caar body) 'set!)
- (eq? (car last-var) (cadar body))))
- (not (any-macro? (caar body) env))
- (not (any? (lambda (p)
- (and (pair? p)
- (not (eq? (car p) 'quote))
- (or (not (hash-table-ref no-side-effect-functions (car p)))
- (any? pair? (cdr p)))))
- (cdar body))))
+ (null? (cddr last-var))
+ (eq? (car body) (car last-var)))
(lint-format "perhaps ~A" caller
- (lists->string form `(,(if (= len 2) 'let 'let*)
- ,(copy varlist (make-list (- len 1)))
- ,@(tree-subst (cadr last-var) (car last-var) body))))))))
-
- (when (and (pair? varlist) ; (let* (...(x A)) (if x (f A) B)) -> (let(*) (...) (cond (A => f) (else B)))
- (pair? body)
- (null? (cdr body)))
- (let* ((varlen (length varlist))
- (var (and (positive? varlen)
- (varlist (- varlen 1)))))
-
- (when (and (pair? var)
- (pair? (cdr var)))
- (let ((p (car body)))
- (when (and (pair? p)
- (pair? (cdr p))
- (case (car p)
- ((if and) (eq? (cadr p) (car var)))
- ((or) (equal? (cadr p) `(not ,(car var))))
- (else #f))
- (pair? (cddr p))
- (pair? (caddr p))
- (or (eq? (car p) 'if)
- (null? (cdddr p)))
- (pair? (cdaddr p))
- (not (eq? (caaddr p) (car var))) ; ! (let* (...(x A)) (if x (x x)))
- (null? (cddr (caddr p)))
- (eq? (car var) (cadr (caddr p))))
-
- (let ((else-clause (cond ((pair? (cdddr p)) ; only if 'if (see above)
- (if (eq? (cadddr p) (car var))
- `((else #f)) ; this stands in for the local var
- (if (and (pair? (cadddr p))
- (tree-unquoted-member (car var) (cadddr p)))
- :oops! ; if the let var appears in the else portion, we can't do anything with =>
- `((else ,(cadddr p))))))
- ((eq? (car p) 'and)
- `((else #f)))
- ((eq? (car p) 'or)
- `((else #t)))
- (else ()))))
- (if (not (eq? else-clause :oops!))
- (case varlen
- ((1) (lint-format "perhaps ~A" caller
- (lists->string form `(cond (,(cadr var) => ,(caaddr p))
- , at else-clause))))
- ((2) (lint-format "perhaps ~A" caller
- (lists->string form `(let (,(car varlist))
- (cond (,(cadr var) => ,(caaddr p))
- , at else-clause)))))
- (else (lint-format "perhaps ~A" caller
- (lists->string form `(let* (,@(copy varlist (make-list (- varlen 1))))
- (cond (,(cadr var) => ,(caaddr p))
- , at else-clause)))))))))))))
- (if (and (pair? body) ; same as let: (let* ((x y)) x) -> y
- (null? (cdr body))
- (pair? varlist) ; (let* ()...)
- (pair? (car varlist)) ; (let* (x) ...)
- (not (pair? (car body))))
- (if (and (eq? (car body) (caar varlist))
- (null? (cdr varlist))
- (pair? (cdar varlist))) ; (let* ((a...)) a)
- (lint-format "perhaps ~A" caller (lists->string form (cadar varlist)))
- (let* ((len (length varlist))
- (last-var (and (positive? len)
- (list-ref varlist (- len 1)))))
- (if (and (> len 1) ; (let* (... (x y)) x) -> (let(*)(...) y)
- (pair? last-var)
- (pair? (cdr last-var))
- (null? (cddr last-var))
- (eq? (car body) (car last-var)))
- (lint-format "perhaps ~A" caller
- (lists->string form `(,(if (= len 2) 'let 'let*)
- ,(copy varlist (make-list (- len 1)))
- ,(cadr last-var))))))))
- (when (and (not named-let)
- (> (length body) 3)
- (> (length vars) 1)
- (every? pair? varlist)
- (not (tree-set-car-member '(define define* define-macro define-macro*
- define-bacro define-bacro* define-constant define-expansion)
+ (lists->string form `(,(if (= varlist-len 2) 'let 'let*)
+ ,(copy varlist (make-list (- varlist-len 1)))
+ ,(cadr last-var)))))))))
+ (when (and (> (length body) 3)
+ (> (length vars) 1)
+ (every? pair? varlist)
+ (not (tree-set-car-member '(define define* define-macro define-macro*
+ define-bacro define-bacro* define-constant define-expansion)
body)))
- (let ((last-ref (vector (var-name (car vars)) #f 0 (car vars))))
- (do ((p body (cdr p))
- (i 0 (+ i 1)))
- ((null? p)
- (let ((len i))
- (if (and (< (last-ref 2) (/ len lint-let-reduction-factor))
- (> (- len (last-ref 2)) 3))
- (lint-format "the scope of ~A could be reduced: ~A" caller
- (last-ref 0)
- (lists->string form
- `(,(if (> (length vars) 2) 'let* 'let)
- ,(copy varlist (make-list (- (length vars) 1)))
- (let (,(list (last-ref 0) (var-initial-value (last-ref 3))))
- ,@(copy body (make-list (+ (last-ref 2) 1))))
- ,(list-ref body (+ (last-ref 2) 1))
- ...))))))
- (when (tree-memq (last-ref 0) (car p))
- (set! (last-ref 2) i)
- (if (not (last-ref 1)) (set! (last-ref 1) i))))))
- )))
- env)
-
- ;; ---------------- letrec ----------------
- ((letrec letrec*)
- (if (< (length form) 3)
- (lint-format "~A is messed up: ~A" caller head (truncated-list->string form))
- (let ((vars ()))
- (cond ((null? (cadr form))
- (lint-format "~A could be let: ~A" caller head (truncated-list->string form)))
- ((not (pair? (cadr form)))
- (lint-format "~A is messed up: ~A" caller head (truncated-list->string form)))
- ((and (null? (cdadr form))
- (eq? head 'letrec*))
- (lint-format "letrec* could be letrec: ~A" caller (truncated-list->string form))))
-
- (do ((bindings (cadr form) (cdr bindings)))
- ((not (pair? bindings))
- (if (not (null? bindings))
- (lint-format "~A variable list is not a proper list? ~S" caller head (cadr form))))
- (when (binding-ok? caller head (car bindings) env #f)
- (set! vars (cons (make-var :name (caar bindings)
- :initial-value (if (and (eq? (caar bindings) (cadar bindings))
- (or (eq? head 'letrec)
- (not (var-member (caar bindings) vars))))
- (begin
- (lint-format "~A is the same as (~A #<undefined>) in ~A" caller
- (car bindings) (caar bindings) head)
- ;; in letrec* ((x 12) (x x)) is an error
- #<undefined>)
- (cadar bindings))
- :definer head)
- vars))))
-
- (when (eq? head 'letrec)
- (check-unordered-exprs caller form (map var-initial-value vars) env))
-
- (if (pair? vars) ; if none of the local vars occurs in any of the values, no need for the "rec"
- (do ((bindings (cadr form) (cdr bindings))
- (vs (map var-name vars)))
- ((or (not (pair? bindings))
- (not (pair? (car bindings)))
- (not (pair? (cdar bindings)))
- (memq (cadar bindings) vs)
- (tree-set-member vs (cadar bindings)))
- (if (null? bindings)
- (lint-format "~A could be ~A: ~A" caller
- head (if (eq? head 'letrec) 'let 'let*)
- (truncated-list->string form))))))
-
- (when (and (pair? vars)
- (null? (cdr vars))
- (pair? (cddr form))
- (pair? (caddr form))
- (null? (cdddr form)))
- (let ((body (caddr form))
- (sym (var-name (car vars)))
- (lform (cadar (cadr form)))) ; the letrec var's lambda
- (when (and (pair? lform)
- (pair? (cdr lform))
- (eq? (car lform) 'lambda)
- (proper-list? (cadr lform))) ; includes ()
- (if (eq? sym (car body)) ; (letrec ((x (lambda ...))) (x...)) -> (let x (...)...)
- (if (and (not (tree-memq sym (cdr body)))
- (< (tree-leaves body) 100))
- ;; the limit on tree-leaves is for cases where the args are long lists of data --
- ;; more like for-each than let, and easier to read if the code is first, I think.
- (lint-format "perhaps ~A" caller
- (lists->string
- form `(let ,sym
- ,(map list (cadr lform) (cdr body))
- ,@(cddr lform)))))
- (if (and (not (eq? caller 'define))
- (= (tree-count1 sym body 0) 1))
- (let ((call (find-call sym body)))
- (when (pair? call)
- (let ((new-call `(let ,sym
- ,(map list (cadr lform) (cdr call))
- ,@(cddr lform))))
- (lint-format "perhaps ~A" caller
- (lists->string form (tree-subst new-call call body)))))))))))
- ;; maybe (let () ...) here because (letrec ((x (lambda (y) (+ y 1)))) (x (define z 32))) needs to block z?
- ;; currently we get (let x ((y (define z 32))) (+ y 1))
- ;; and even that should be (let () (define z 32) (+ z 1)) or something similar
- ;; lambda here is handled under define??
-
- (let ((new-env (append vars env)))
- (do ((bindings (cadr form) (cdr bindings)))
- ((not (pair? bindings)))
- (if (binding-ok? caller head (car bindings) env #t)
- (lint-walk caller (cadar bindings) new-env)))
-
- (let* ((cur-env (append vars env))
- (e (lint-walk-body caller head (cddr form) cur-env))
- (nvars (and (not (eq? e cur-env))
- (env-difference caller e cur-env ()))))
- (if (pair? nvars)
- (if (eq? (var-name (car nvars)) :lambda)
- (begin
- (set! env (cons (car nvars) env))
- (set! nvars (cdr nvars)))
- (set! vars (append nvars vars))))
-
- (report-usage caller head vars cur-env))))) ; constant exprs never happen here
- env)
-
- ;; ---------------- begin ----------------
- ((begin)
- (if (not (proper-list? form))
- (begin
- (lint-format "stray dot in begin? ~A" caller (truncated-list->string form))
- env)
- (begin
- (if (and (pair? (cdr form))
- (null? (cddr form)))
- (lint-format "begin could be omitted: ~A" caller (truncated-list->string form)))
- (lint-walk-open-body caller head (cdr form) env))))
-
- ;; ---------------- with-baffle ----------------
- ;; with-baffle introduces a new frame, so we need to handle it here
- ((with-baffle)
- (lint-walk-body caller head (cdr form) env)
- env)
-
- ;; -------- with-let --------
- ((with-let)
- (if (< (length form) 3)
- (lint-format "~A is messed up: ~A" head caller (truncated-list->string form))
- (let ((e (cadr form)))
- (if (or (and (code-constant? e)
- (not (let? e)))
- (and (pair? e)
- (let ((op (return-type (car e) env)))
- (and op
- (not (return-type-ok? 'let? op))))))
- (lint-format "~A: first argument should be an environment: ~A" head caller (truncated-list->string form)))
-
- (if (symbol? e)
- (set-ref e caller form env)
- (if (pair? e)
- (begin
- (if (and (null? (cdr e))
- (eq? (car e) 'curlet))
- (lint-format "~A is not needed here: ~A" head caller (truncated-list->string form)))
- (lint-walk caller e env))))
- (let ((walked #f)
- (new-env (cons (make-var :name :with-let :initial-value form :definer head) env)))
- (if (or (and (symbol? e)
- (memq e '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*)))
- (and (pair? e)
- (eq? (car e) 'sublet)
- (pair? (cdr e))
- (memq (cadr e) '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*))
- (set! e (cadr e))))
- (let ((lib (if (defined? e)
- (symbol->value e)
- (let ((file (*autoload* e)))
- (and (string? file)
- (load file))))))
- (when (let? lib)
- (let ((old-e *e*))
- (set! *e* lib)
- (let ((e (lint-walk-open-body caller head (cddr form) new-env)))
- (report-usage caller head
- (if (eq? e env)
- ()
- (env-difference caller e env ()))
- new-env))
- (set! *e* old-e)
- (set! walked #t)))))
-
- (unless walked
- (lint-walk-open-body caller head (cddr form) new-env)))))
- env)
+ (let ((last-ref (vector (var-name (car vars)) #f 0 (car vars))))
+ (do ((p body (cdr p))
+ (i 0 (+ i 1)))
+ ((null? p)
+ (if (and (< (last-ref 2) (/ i lint-let-reduction-factor))
+ (> (- i (last-ref 2)) 3))
+ (lint-format "the scope of ~A could be reduced: ~A" caller
+ (last-ref 0)
+ (lists->string form
+ `(,(if (> (length vars) 2) 'let* 'let)
+ ,(copy varlist (make-list (- (length vars) 1)))
+ (let (,(list (last-ref 0) (var-initial-value (last-ref 3))))
+ ,@(copy body (make-list (+ (last-ref 2) 1))))
+ ,(list-ref body (+ (last-ref 2) 1))
+ ...)))))
+ (when (tree-memq (last-ref 0) (car p))
+ (set! (last-ref 2) i)
+ (if (not (last-ref 1)) (set! (last-ref 1) i))))))
+ )))))
+ env)
+ (hash-table-set! h 'let* let*-walker))
+
+ ;; ---------------- letrec ----------------
+ (let ()
+ (define (letrec-walker caller form env)
+ (if (< (length form) 3)
+ (lint-format "~A is messed up: ~A" caller (car form) (truncated-list->string form))
+ (let ((vars ())
+ (head (car form)))
- ;; ---------------- defmacro ----------------
- ((defmacro defmacro*)
- (if (or (< (length form) 4)
- (not (symbol? (cadr form))))
- (begin
- (lint-format "~A declaration is messed up: ~A" caller head (truncated-list->string form))
- env)
- (let ((sym (cadr form))
- (args (caddr form))
- (body (cdddr form)))
- (if (and (pair? args)
- (repeated-member? args env))
- (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args))
- (lint-format "~A is deprecated; perhaps ~A" caller head
- (truncated-lists->string form
- `(,(if (eq? head 'defmacro) 'define-macro 'define-macro*)
- ,(cons sym args)
- , at body))))
- (lint-walk-function head sym args body form env)
- (cons (make-var :name sym :initial-value form :definer head) env))))
+ (cond ((null? (cadr form))
+ (lint-format "~A could be let: ~A" caller head (truncated-list->string form)))
+ ((not (pair? (cadr form)))
+ (lint-format "~A is messed up: ~A" caller head (truncated-list->string form)))
+ ((and (null? (cdadr form))
+ (eq? head 'letrec*))
+ (lint-format "letrec* could be letrec: ~A" caller (truncated-list->string form))))
- ;; ---------------- defgenerator ----------------
- ((defgenerator)
- (append (get-generator caller form env) env))
+ (do ((warned (or (eq? head 'letrec*)
+ (not (pair? (cadr form)))
+ (negative? (length (cadr form))))) ; malformed letrec
+ (baddy #f)
+ (bindings (cadr form) (cdr bindings)))
+ ((not (pair? bindings))
+ (if (not (null? bindings))
+ (lint-format "~A variable list is not a proper list? ~S" caller head (cadr form))))
+
+ (when (and (not warned) ; letrec -> letrec*
+ (pair? (car bindings))
+ (pair? (cdar bindings))
+ ;; type of current var is not important -- if used in non-function elsewhere,
+ ;; it has to be letrec*
+ (any? (lambda (b)
+ (and (pair? b)
+ (pair? (cdr b))
+ (or (and (not (pair? (cadr b)))
+ (eq? (caar bindings) (cadr b)))
+ (tree-memq (caar bindings) (cadr b)))
+ (not (tree-set-member '(lambda lambda* define define* case-lambda) (cadr b)))
+ (set! baddy b)))
+ (cdr bindings)))
+ (set! warned #t)
+ (lint-format "in ~A,~%~NCletrec should be letrec* because ~A is used in ~A's value (not a function): ~A" caller
+ (truncated-list->string form)
+ (+ lint-left-margin 4) #\space
+ (caar bindings)
+ (car baddy)
+ (cadr baddy)))
+
+ (when (binding-ok? caller head (car bindings) env #f)
+ (set! vars (cons (make-var :name (caar bindings)
+ :initial-value (if (and (eq? (caar bindings) (cadar bindings))
+ (or (eq? head 'letrec)
+ (not (var-member (caar bindings) vars))))
+ (begin
+ (lint-format "~A is the same as (~A #<undefined>) in ~A" caller
+ (car bindings) (caar bindings) head)
+ ;; in letrec* ((x 12) (x x)) is an error
+ #<undefined>)
+ (cadar bindings))
+ :definer head)
+ vars))))
-
- ;; ---------------- load ----------------
- ((load)
- (lint-walk caller (cdr form) env)
- (if (and *report-loaded-files*
- (string? (cadr form)))
- (catch #t
- (lambda ()
- (lint-file (cadr form) env))
- (lambda args
- env))
- env))
-
- ;; ---------------- require ----------------
- ((require)
- (if (not *report-loaded-files*)
- env
- (let ((vars env))
- (for-each
- (lambda (f)
- (let ((file (*autoload* f)))
- (if (string? file)
- (catch #t
- (lambda ()
- (set! vars (lint-file file vars)))
- (lambda args
- #f)))))
- (cdr form))
- vars)))
-
- ;; ----------------
- ((call-with-input-string call-with-input-file call-with-output-file call-with-output-string)
- (let ((len (if (eq? head 'call-with-output-string) 2 3))) ; call-with-output-string func is the first arg, not second
- (when (= (length form) len)
- (let ((func (list-ref form (- len 1))))
- (if (= len 3)
- (lint-walk caller (cadr form) env))
- (if (not (and (pair? func)
- (eq? (car func) 'lambda)))
- (lint-walk caller func env)
- (let* ((args (cadr func))
- (body (cddr func))
- (port (and (pair? args) (car args))))
- (if (or (not port)
- (pair? (cdr args)))
- (lint-format "~A argument should be a function of one argument: ~A" caller head func)
- (if (and (null? (cdr body))
- (pair? (car body))
- (pair? (cdar body))
- (eq? (cadar body) port)
- (null? (cddar body)))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if (= len 2)
- `(,head ,(caar body))
- `(,head ,(cadr form) ,(caar body)))))
- (let ((cc (make-var :name port
- :initial-value (list (case head
- ((call-with-input-string) 'open-input-string)
- ((call-with-output-string) 'open-output-string)
- ((call-with-input-file) 'open-input-file)
- ((call-with-output-file) 'open-output-file)))
- :definer head)))
- (lint-walk-body caller head body (cons cc env))
- (report-usage caller head (list cc) env)))))))))
- env)
+ (when (eq? head 'letrec)
+ (check-unordered-exprs caller form (map var-initial-value vars) env))
- ;; ----------------
- ((catch)
- ;; catch tag is tricky -- it is evaluated, then eq? matches at error time, so we need
- ;; to catch constants that can't be eq?
- ;; also I'm not sure the catch marker business below buys anything -- these are dynamic, not lexical,
- ;; so lint can't make any pronouncements about them.
- (if (not (= (length form) 4))
- (begin
- (lint-format "catch takes 3 arguments (tag body error-handler): ~A" caller (truncated-list->string form))
- (lint-walk caller (cdr form) env))
- (let ((tag (cadr form)))
- (if (or (and (not (pair? tag))
- (or (number? tag) (char? tag) (length tag)))
- (and (pair? tag)
- (eq? (car tag) 'quote)
- (or (not (pair? (cdr tag)))
- (length (cadr tag)))))
- (lint-format "catch tag ~S is unreliable (catch uses eq? to match tags)" caller tag))
- (let ((body (caddr form))
- (error-handler (cadddr form)))
- ;; empty catch+catch apparently never happens
- (lint-walk caller body (cons (make-var :name :catch
- :initial-value form
- :definer head)
- env))
- (lint-walk caller error-handler env))))
- env)
+ (when (pair? vars)
+ (do ((bindings (cadr form) (cdr bindings)) ; if none of the local vars occurs in any of the values, no need for the "rec"
+ (vs (map var-name vars)))
+ ((or (not (pair? bindings))
+ (not (pair? (car bindings)))
+ (not (pair? (cdar bindings)))
+ (memq (cadar bindings) vs)
+ (tree-set-member vs (cadar bindings)))
+ (if (null? bindings)
+ (lint-format "~A could be ~A: ~A" caller
+ head (if (or (eq? head 'letrec)
+ (do ((p (map cadr (cadr form)) (cdr p))
+ (q (map car (cadr form)) (cdr q)))
+ ((or (null? p)
+ (side-effect? (car p) env)
+ (memq (car q) (cdr q)))
+ (null? p))))
+ 'let 'let*)
+ (truncated-list->string form)))))
+
+ (when (and (null? (cdr vars))
+ (pair? (cddr form))
+ (pair? (caddr form))
+ (null? (cdddr form)))
+ (let ((body (caddr form))
+ (sym (var-name (car vars)))
+ (lform (cadar (cadr form)))) ; the letrec var's lambda
+ (when (and (pair? lform)
+ (pair? (cdr lform))
+ (eq? (car lform) 'lambda)
+ (proper-list? (cadr lform))) ; includes ()
+ (if (eq? sym (car body)) ; (letrec ((x (lambda ...))) (x...)) -> (let x (...)...)
+ (if (and (not (tree-memq sym (cdr body)))
+ (< (tree-leaves body) 100))
+ ;; the limit on tree-leaves is for cases where the args are long lists of data --
+ ;; more like for-each than let, and easier to read if the code is first, I think.
+ (lint-format "perhaps ~A" caller
+ (lists->string
+ form `(let ,sym
+ ,(map list (cadr lform) (cdr body))
+ ,@(cddr lform)))))
+ (if (and (not (eq? caller 'define))
+ (= (tree-count1 sym body 0) 1))
+ (let ((call (find-call sym body)))
+ (when (pair? call)
+ (let ((new-call `(let ,sym
+ ,(map list (cadr lform) (cdr call))
+ ,@(cddr lform))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form (tree-subst new-call call body))))))))))))
+ ;; maybe (let () ...) here because (letrec ((x (lambda (y) (+ y 1)))) (x (define z 32))) needs to block z?
+ ;; currently we get (let x ((y (define z 32))) (+ y 1))
+ ;; and even that should be (let () (define z 32) (+ z 1)) or something similar
+ ;; lambda here is handled under define??
- ;; ----------------
- ((call/cc call-with-current-continuation call-with-exit)
- (let ((continuation (and (pair? (cdr form))
- (pair? (cadr form))
- (eq? (caadr form) 'lambda)
- (pair? (cdadr form))
- (pair? (cddadr form))
- (pair? (cadadr form))
- (car (cadadr form)))))
- (if (not (symbol? continuation))
- (lint-walk caller (cdr form) env)
- (let ((body (cddadr form)))
-
- (if (not (or (eq? head 'call-with-exit)
- (eq? continuation (car body))
- (tree-sym-set-member continuation '(lambda lambda* define define* curlet error apply) body)))
- ;; this checks for continuation as arg (of anything), and any of set as car
- (lint-format* caller
- (string-append "perhaps " (symbol->string head))
- " could be call-with-exit: "
- (truncated-list->string form)))
-
- (if (not (tree-unquoted-member continuation body))
- (lint-format "~A ~A ~A appears to be unused: ~A" caller head
- (if (eq? head 'call-with-exit) "exit function" "continuation")
- continuation
- (truncated-list->string form))
- (let ((last (and (proper-list? body)
- (list-ref body (- (length body) 1)))))
- (if (and (pair? last)
- (eq? (car last) continuation))
- (lint-format "~A is redundant here: ~A" caller continuation (truncated-list->string last)))))
-
- (let ((cc (make-var :name continuation
- :initial-value (if (eq? head 'call-with-exit) :call/exit :call/cc)
- :definer head)))
- (lint-walk-body caller head body (cons cc env))
- (report-usage caller head (list cc) env)))))
- env)
-
- ;; ----------------
- ((define-module import export) ; module apparently has different syntax and expectations in various schemes
- env)
-
- ((define-syntax)
- ;; we need to put the macro name in env with ftype=define-syntax
- (if (and (pair? (cdr form))
- (symbol? (cadr form))
- (not (keyword? (cadr form)))) ; !! this thing is a disaster from the very start
- (cons (make-fvar (cadr form) :ftype 'define-syntax) env)
- env))
-
- ((define-method) ; guile and mit-scheme have different syntaxes here
- (if (not (and (pair? (cdr form))
- (pair? (cddr form))))
- env
- (if (symbol? (cadr form))
- (if (keyword? (cadr form))
- (lint-walk-body caller head (cdddr form) env)
- (let ((new-env (if (var-member (cadr form) env)
- env
- (cons (make-fvar (cadr form) :ftype 'define-method) env))))
- (lint-walk-body caller (cadr form) (cdddr form) new-env)))
- (let ((new-env (if (var-member (caadr form) env)
- env
- (cons (make-fvar (caadr form) :ftype 'define-method) env))))
- (lint-walk-body caller (caadr form) (cddr form) new-env)))))
-
- ((let-syntax letrec-syntax)
- (lint-walk-body caller head (cddr form) env)
- env)
-
- ;; ----------------
- ((case-lambda)
- (when (pair? (cdr form))
- (let ((lens ())
- (body (if (string? (cadr form)) (cddr form) (cdr form))) ; might have a doc string before the clauses
- (doc-string (and (string? (cadr form)) (cadr form))))
-
- (define (arg->defaults arg b1 b2 defaults)
- (and defaults
- (cond ((null? b1) (and (null? b2) defaults))
- ((null? b2) (and (null? b1) defaults))
- ((eq? arg b1) (cons b2 defaults))
- ((eq? arg b2) (cons b1 defaults))
- ((pair? b1)
- (and (pair? b2)
- (arg->defaults arg (car b1) (car b2) (arg->defaults arg (cdr b1) (cdr b2) defaults))))
- (else (and (equal? b1 b2) defaults)))))
- (for-each
- (lambda (choice)
- (if (pair? choice)
- (let ((len (length (car choice))))
- (if (member len lens)
- (lint-format "repeated parameter list? ~A in ~A" caller (car choice) form))
- (set! lens (cons len lens))
- (lint-walk 'case-lambda `(lambda , at choice) env))))
- body)
-
- (case (length lens)
- ((1)
- (lint-format "perhaps ~A" caller
- (lists->string form
+ (let ((new-env (append vars env)))
+ (do ((bindings (cadr form) (cdr bindings)))
+ ((not (pair? bindings)))
+ (if (binding-ok? caller head (car bindings) env #t)
+ (lint-walk caller (cadar bindings) new-env)))
+
+ (let* ((cur-env (cons (make-var :name :let
+ :initial-value form
+ :definer head)
+ (append vars env)))
+ (e (lint-walk-body caller head (cddr form) cur-env)))
+
+ (let ((nvars (and (not (eq? e cur-env))
+ (env-difference caller e cur-env ()))))
+ (if (pair? nvars)
+ (if (eq? (var-name (car nvars)) :lambda)
+ (begin
+ (set! env (cons (car nvars) env))
+ (set! nvars (cdr nvars)))
+ (set! vars (append nvars vars)))))
+
+ (report-usage caller head vars cur-env))))) ; constant exprs never happen here
+ env)
+ (hash-table-set! h 'letrec letrec-walker)
+ (hash-table-set! h 'letrec* letrec-walker))
+
+
+ ;; ---------------- begin ----------------
+ (let ()
+ (define (begin-walker caller form env)
+
+ (if (not (proper-list? form))
+ (begin
+ (lint-format "stray dot in begin? ~A" caller (truncated-list->string form))
+ env)
+ (begin
+ (if (and (pair? (cdr form))
+ (null? (cddr form)))
+ (lint-format "begin could be omitted: ~A" caller (truncated-list->string form)))
+ (lint-walk-open-body caller 'begin (cdr form) env))))
+ (hash-table-set! h 'begin begin-walker))
+
+
+ ;; ---------------- with-baffle ----------------
+ ;; with-baffle introduces a new frame, so we need to handle it here
+ (hash-table-set!
+ h 'with-baffle
+ (lambda (caller form env)
+ (lint-walk-body caller 'with-baffle (cdr form)
+ (cons (make-var :name :let
+ :initial-value form
+ :definer 'with-baffle)
+ env))
+ env))
+
+
+ ;; -------- with-let --------
+ (hash-table-set!
+ h 'with-let
+ (lambda (caller form env)
+ (if (< (length form) 3)
+ (lint-format "~A is messed up: ~A" 'with-let caller (truncated-list->string form))
+ (let ((e (cadr form)))
+ (if (or (and (code-constant? e)
+ (not (let? e)))
+ (and (pair? e)
+ (let ((op (return-type (car e) env)))
+ (and op
+ (not (return-type-ok? 'let? op))))))
+ (lint-format "~A: first argument should be an environment: ~A" 'with-let caller (truncated-list->string form)))
+
+ (if (symbol? e)
+ (set-ref e caller form env)
+ (if (pair? e)
+ (begin
+ (if (and (null? (cdr e))
+ (eq? (car e) 'curlet))
+ (lint-format "~A is not needed here: ~A" 'with-let caller (truncated-list->string form)))
+ (lint-walk caller e (cons (make-var :name :let
+ :initial-value form
+ :definer 'with-let)
+ env)))))
+ (let ((walked #f)
+ (new-env (cons (make-var :name :with-let :initial-value form :definer 'with-let) env)))
+ (if (or (and (symbol? e)
+ (memq e '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*)))
+ (and (pair? e)
+ (eq? (car e) 'sublet)
+ (pair? (cdr e))
+ (memq (cadr e) '(*gtk* *motif* *gl* *libc* *libm* *libgdbm* *libgsl*))
+ (set! e (cadr e))))
+ (let ((lib (if (defined? e)
+ (symbol->value e)
+ (let ((file (*autoload* e)))
+ (and (string? file)
+ (load file))))))
+ (when (let? lib)
+ (let-temporarily ((*e* lib))
+ (let ((e (lint-walk-open-body caller 'with-let (cddr form) new-env)))
+ (report-usage caller 'with-let
+ (if (eq? e env)
+ ()
+ (env-difference caller e env ()))
+ new-env)))
+ (set! walked #t))))
+
+ (unless walked
+ (lint-walk-open-body caller 'with-let (cddr form) new-env)))))
+ env))
+
+
+ ;; ---------------- defmacro ----------------
+ (let ()
+ (define (defmacro-walker caller form env)
+ (if (or (< (length form) 4)
+ (not (symbol? (cadr form))))
+ (begin
+ (lint-format "~A declaration is messed up: ~A" caller (car form) (truncated-list->string form))
+ env)
+ (let ((sym (cadr form))
+ (args (caddr form))
+ (body (cdddr form))
+ (head (car form)))
+ (if (and (pair? args)
+ (repeated-member? args env))
+ (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args))
+ (lint-format "~A is deprecated; perhaps ~A" caller head
+ (truncated-lists->string form
+ `(,(if (eq? head 'defmacro) 'define-macro 'define-macro*)
+ ,(cons sym args)
+ , at body))))
+ (lint-walk-function head sym args body form env)
+ (cons (make-var :name sym :initial-value form :definer head) env))))
+ (hash-table-set! h 'defmacro defmacro-walker)
+ (hash-table-set! h 'defmacro* defmacro-walker))
+
+
+ ;; ---------------- load ----------------
+ (hash-table-set!
+ h 'load
+ (lambda (caller form env)
+ (lint-walk caller (cdr form) env)
+ (if (and *report-loaded-files*
+ (string? (cadr form)))
+ (catch #t
+ (lambda ()
+ (lint-file (cadr form) env))
+ (lambda args
+ env))
+ env)))
+
+
+ ;; ---------------- require ----------------
+ (hash-table-set!
+ h 'require
+ (lambda (caller form env)
+ (if (not *report-loaded-files*)
+ env
+ (let ((vars env))
+ (for-each
+ (lambda (f)
+ (let ((file (*autoload* f)))
+ (if (string? file)
+ (catch #t
+ (lambda ()
+ (set! vars (lint-file file vars)))
+ (lambda args
+ #f)))))
+ (cdr form))
+ vars))))
+
+
+ ;; ---------------- call-with-input-file etc ----------------
+ (let ()
+ (define (call-with-io-walker caller form env)
+ (let ((len (if (eq? (car form) 'call-with-output-string) 2 3))) ; call-with-output-string func is the first arg, not second
+ (when (= (length form) len)
+ (let ((func (list-ref form (- len 1))))
+ (if (= len 3)
+ (lint-walk caller (cadr form) env))
+ (if (not (and (pair? func)
+ (eq? (car func) 'lambda)))
+ (lint-walk caller func env)
+ (let* ((args (cadr func))
+ (body (cddr func))
+ (port (and (pair? args) (car args)))
+ (head (car form)))
+ (if (or (not port)
+ (pair? (cdr args)))
+ (lint-format "~A argument should be a function of one argument: ~A" caller head func)
+ (if (and (null? (cdr body))
+ (pair? (car body))
+ (pair? (cdar body))
+ (eq? (cadar body) port)
+ (null? (cddar body)))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if (= len 2)
+ `(,head ,(caar body))
+ `(,head ,(cadr form) ,(caar body)))))
+ (let ((cc (make-var :name port
+ :initial-value (list (case head
+ ((call-with-input-string) 'open-input-string)
+ ((call-with-output-string) 'open-output-string)
+ ((call-with-input-file) 'open-input-file)
+ ((call-with-output-file) 'open-output-file)))
+ :definer head)))
+ (lint-walk-body caller head body (cons cc
+ (cons (make-var :name :let
+ :initial-value form
+ :definer head)
+ env)))
+ (report-usage caller head (list cc) env)))))))))
+ env)
+ (for-each (lambda (op)
+ (hash-table-set! h op call-with-io-walker))
+ '(call-with-input-string call-with-input-file call-with-output-file call-with-output-string)))
+
+
+ ;; ---------------- catch ----------------
+ (let ()
+ (define (catch-walker caller form env)
+ ;; catch tag is tricky -- it is evaluated, then eq? matches at error time, so we need
+ ;; to catch constants that can't be eq?
+ (if (not (= (length form) 4))
+ (begin
+ (lint-format "catch takes 3 arguments (tag body error-handler): ~A" caller (truncated-list->string form))
+ (lint-walk caller (cdr form) env))
+ (let ((tag (cadr form)))
+ (if (or (and (not (pair? tag))
+ (or (number? tag) (char? tag) (length tag)))
+ (and (pair? tag)
+ (eq? (car tag) 'quote)
+ (or (not (pair? (cdr tag)))
+ (length (cadr tag)))))
+ (lint-format "catch tag ~S is unreliable (catch uses eq? to match tags)" caller tag))
+ (let ((body (caddr form))
+ (error-handler (cadddr form)))
+ ;; empty catch+catch apparently never happens
+ (lint-walk caller body (cons (make-var :name :let
+ :initial-value form
+ :definer 'catch)
+ (cons (make-var :name :catch
+ :initial-value form
+ :definer 'catch)
+ env)))
+ (lint-walk caller error-handler env))))
+ env)
+ (hash-table-set! h 'catch catch-walker))
+
+
+ ;; ---------------- call-with-exit etc ----------------
+ (let ()
+ (define (call-with-exit-walker caller form env)
+ (let ((continuation (and (pair? (cdr form))
+ (pair? (cadr form))
+ (eq? (caadr form) 'lambda)
+ (pair? (cdadr form))
+ (pair? (cddadr form))
+ (pair? (cadadr form))
+ (car (cadadr form)))))
+ (if (not (symbol? continuation))
+ (lint-walk caller (cdr form) env)
+ (let ((body (cddadr form))
+ (head (car form)))
+
+ (if (not (or (eq? head 'call-with-exit)
+ (eq? continuation (car body))
+ (tree-sym-set-member continuation '(lambda lambda* define define* curlet error apply) body)))
+ ;; this checks for continuation as arg (of anything), and any of set as car
+ (lint-format* caller
+ (string-append "perhaps " (symbol->string head))
+ " could be call-with-exit: "
+ (truncated-list->string form)))
+
+ (if (not (tree-unquoted-member continuation body))
+ (lint-format "~A ~A ~A appears to be unused: ~A" caller head
+ (if (eq? head 'call-with-exit) "exit function" "continuation")
+ continuation
+ (truncated-list->string form))
+ (let ((last (and (proper-list? body)
+ (list-ref body (- (length body) 1)))))
+ (if (and (pair? last)
+ (eq? (car last) continuation))
+ (lint-format "~A is redundant here: ~A" caller continuation (truncated-list->string last)))))
+
+ (let ((cc (make-var :name continuation
+ :initial-value (if (eq? head 'call-with-exit) :call/exit :call/cc)
+ :definer head)))
+ (lint-walk-body caller head body (cons cc env))
+ (report-usage caller head (list cc) env)))))
+ env)
+ (for-each (lambda (op)
+ (hash-table-set! h op call-with-exit-walker))
+ '(call/cc call-with-current-continuation call-with-exit)))
+
+
+ ;; ---------------- import etc ----------------
+ (for-each (lambda (op)
+ (hash-table-set! h op (lambda (caller form env) env)))
+ '(define-module import export))
+
+ (hash-table-set!
+ h 'provide
+ (lambda (caller form env)
+ (if (not (= (length form) 2))
+ (lint-format "provide takes one argument: ~A" caller (truncated-list->string form))
+ (unless (symbol? (cadr form))
+ (let ((op (->lint-type (cadr form))))
+ (if (not (memq op '(symbol? #f #t values)))
+ (lint-format "provide's argument should be a symbol: ~S" caller form)))))
+ env))
+
+ (hash-table-set!
+ h 'module ; module apparently has different syntax and expectations in various schemes
+ (lambda (caller form env)
+ (if (and (pair? (cdr form))
+ (pair? (cddr form)))
+ (lint-walk 'module (cddr form) env))
+ env))
+
+ (hash-table-set!
+ h 'define-syntax
+ (lambda (caller form env)
+ ;; we need to put the macro name in env with ftype=define-syntax
+ (if (and (pair? (cdr form))
+ (symbol? (cadr form))
+ (not (keyword? (cadr form)))) ; !! this thing is a disaster from the very start
+ (cons (make-fvar (cadr form) :ftype 'define-syntax) env)
+ env)))
+
+ (hash-table-set!
+ h 'define-method ; guile and mit-scheme have different syntaxes here
+ (lambda (caller form env)
+ (if (not (and (pair? (cdr form))
+ (pair? (cddr form))))
+ env
+ (if (symbol? (cadr form))
+ (if (keyword? (cadr form))
+ (lint-walk-body caller 'define-method (cdddr form) env)
+ (let ((new-env (if (var-member (cadr form) env)
+ env
+ (cons (make-fvar (cadr form) :ftype 'define-method) env))))
+ (lint-walk-body caller (cadr form) (cdddr form) new-env)))
+ (let ((new-env (if (var-member (caadr form) env)
+ env
+ (cons (make-fvar (caadr form) :ftype 'define-method) env))))
+ (lint-walk-body caller (caadr form) (cddr form) new-env))))))
+
+ (hash-table-set! h 'let-syntax (lambda (caller form env)
+ (lint-walk-body caller 'define-method (cddr form) env)
+ env))
+
+ (hash-table-set! h 'letrec-syntax (lambda (caller form env)
+ (lint-walk-body caller 'define-method (cddr form) env)
+ env))
+
+
+ ;; ---------------- case-lambda ----------------
+ (hash-table-set!
+ h 'case-lambda
+ (lambda (caller form env)
+ (when (pair? (cdr form))
+ (let ((lens ())
+ (body ((if (string? (cadr form)) cddr cdr) form)) ; might have a doc string before the clauses
+ (doc-string (and (string? (cadr form)) (cadr form))))
+
+ (define (arg->defaults arg b1 b2 defaults)
+ (and defaults
+ (cond ((null? b1) (and (null? b2) defaults))
+ ((null? b2) (and (null? b1) defaults))
+ ((eq? arg b1) (cons b2 defaults))
+ ((eq? arg b2) (cons b1 defaults))
+ ((pair? b1)
+ (and (pair? b2)
+ (arg->defaults arg (car b1) (car b2) (arg->defaults arg (cdr b1) (cdr b2) defaults))))
+ (else (and (equal? b1 b2) defaults)))))
+ (for-each
+ (lambda (choice)
+ (if (pair? choice)
+ (let ((len (length (car choice))))
+ (if (member len lens)
+ (lint-format "repeated parameter list? ~A in ~A" caller (car choice) form))
+ (set! lens (cons len lens))
+ (lint-walk 'case-lambda (cons 'lambda choice) env))))
+ body)
+
+ (case (length lens)
+ ((1)
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ (if doc-string
+ `(let ((documentation ,doc-string))
+ (lambda ,(caar body) ,@(cdar body)))
+ `(lambda ,(caar body) ,@(cdar body))))))
+ ((2)
+ (when (let arglists-equal? ((args1 (caar body))
+ (args2 (caadr body)))
+ (if (null? args1)
+ (and (pair? args2) (null? (cdr args2)))
+ (and (pair? args1)
+ (if (null? args2)
+ (null? (cdr args1))
+ (and (pair? args2)
+ (eq? (car args1) (car args2))
+ (arglists-equal? (cdr args1) (cdr args2)))))))
+ (let* ((clause1 (car body))
+ (arg1 (car clause1))
+ (body1 (cdr clause1))
+ (clause2 (cadr body))
+ (arg2 (car clause2))
+ (body2 (cdr clause2))
+ (arglist (if (> (car lens) (cadr lens)) arg2 arg1)) ; lens is reversed
+ (arg-name (list-ref arglist (- (length arglist) 1)))
+ (diffs (arg->defaults arg-name body1 body2 ())))
+ (when (and (pair? diffs)
+ (null? (cdr diffs))
+ (code-constant? (car diffs)))
+ (let ((new-body (if (> (car lens) (cadr lens)) body2 body1))
+ (new-arglist (if (not (car diffs))
+ arglist
+ (if (null? (cdr arglist))
+ `((,arg-name ,(car diffs)))
+ `(,(car arglist) (,arg-name ,(car diffs)))))))
+ (lint-format "perhaps ~A" caller
+ (lists->string form
(if doc-string
`(let ((documentation ,doc-string))
- (lambda ,(caar body) ,@(cdar body)))
- `(lambda ,(caar body) ,@(cdar body))))))
- ((2)
- (when (let arglists-equal? ((args1 (caar body))
- (args2 (caadr body)))
- (if (null? args1)
- (and (pair? args2) (null? (cdr args2)))
- (and (pair? args1)
- (if (null? args2)
- (null? (cdr args1))
- (and (pair? args2)
- (eq? (car args1) (car args2))
- (arglists-equal? (cdr args1) (cdr args2)))))))
- (let* ((clause1 (car body))
- (arg1 (car clause1))
- (body1 (cdr clause1))
- (clause2 (cadr body))
- (arg2 (car clause2))
- (body2 (cdr clause2))
- (arglist (if (> (car lens) (cadr lens)) arg2 arg1)) ; lens is reversed
- (arg-name (list-ref arglist (- (length arglist) 1)))
- (diffs (arg->defaults arg-name body1 body2 ())))
- (when (and (pair? diffs)
- (null? (cdr diffs))
- (code-constant? (car diffs)))
- (let ((new-body (if (> (car lens) (cadr lens)) body2 body1))
- (new-arglist (if (not (car diffs))
- arglist
- (if (null? (cdr arglist))
- `((,arg-name ,(car diffs)))
- `(,(car arglist) (,arg-name ,(car diffs)))))))
- (lint-format "perhaps ~A" caller
- (lists->string form
- (if doc-string
- `(let ((documentation ,doc-string))
- (lambda* ,new-arglist , at new-body))
- `(lambda* ,new-arglist , at new-body))))))))))))
- env)
-
- ;; ---------------- everything else ----------------
- (else
- (if (not (proper-list? form))
- ;; these appear to be primarily macro/match arguments
- ;; other cases (not list) have already been dealt with far above
- (if (and (pair? form)
- (symbol? head)
- (procedure? (symbol->value head *e*)))
- (lint-format "unexpected dot: ~A" caller (truncated-list->string form)))
- (begin
- (when (symbol? head)
+ (lambda* ,new-arglist , at new-body))
+ `(lambda* ,new-arglist , at new-body))))))))))))
+ env))
+ h))
+
+
+ (define lint-walk-pair
+ (let ((unsafe-makers '(sublet inlet copy cons list append make-shared-vector vector hash-table hash-table*
+ make-hash-table make-hook #_{list} #_{append} gentemp or and not)))
+ (lambda (caller form env)
+ (let ((head (car form)))
+
+ (set! line-number (pair-line-number form))
+
+ (when *report-function-stuff*
+ (function-match caller form env))
+
+ (cond
+ ((hash-table-ref walker-functions head)
+ => (lambda (f)
+ (f caller form env)))
+ (else
+ (if (not (proper-list? form))
+ ;; these appear to be primarily macro/match arguments
+ ;; other cases (not list) have already been dealt with far above
+ (if (and (pair? form)
+ (symbol? head)
+ (procedure? (symbol->value head *e*)))
+ (lint-format "unexpected dot: ~A" caller (truncated-list->string form)))
+ (begin
+ (cond ((symbol? head)
(let ((v (var-member head env)))
(if (and (var? v)
(not (memq form (var-history v))))
(set! (var-history v) (cons form (var-history v))))
(check-call caller head form env)
-
+
+ ;; look for one huge argument leaving lonely trailing arguments somewhere off the screen
+ (let ((branches (length form)))
+ (when (and (> branches 2)
+ (not (any-macro? head env))
+ (not (memq head '(for-each map #_{list} * + - /))))
+ (let ((leaves (tree-leaves form)))
+ (when (> leaves (max *report-bloated-arg* (* branches 3)))
+ (do ((p (cdr form) (cdr p))
+ (i 1 (+ i 1)))
+ ((or (not (pair? p))
+ (null? (cdr p))
+ (and (pair? (car p))
+ (symbol? (caar p))
+ (not (memq (caar p) '(lambda quote call/cc list vector match-lambda)))
+ (> (tree-leaves (car p)) (- leaves (* branches 2)))
+ (or (not (memq head '(or and)))
+ (= i 1))
+ (let ((header (copy form (make-list i)))
+ (trailer (copy form (make-list (- branches i 1)) (+ i 1)))
+ (disclaimer (if (or (hash-table-ref built-in-functions head)
+ (hash-table-ref no-side-effect-functions head)
+ (let ((v (var-member head env)))
+ (and (var? v)
+ (memq (var-ftype v) '(define define* lambda lambda*)))))
+ ""
+ (format #f ", assuming ~A is not a macro," head))))
+ (lint-format "perhaps~A~% ~A ->~% ~A" caller disclaimer
+ (lint-pp `(, at header ,(one-call-and-dots (car p)) , at trailer))
+ (lint-pp `(let ((_1_ ,(one-call-and-dots (car p))))
+ (, at header _1_ , at trailer))))
+ #t)))))))))
+
(when (pair? form)
;; save any references to vars in their var-history (type checked later)
;; this can be fooled by macros, as everywhere else
@@ -13270,20 +15268,12 @@
(if (and (var? v)
(not (memq form (var-history v))))
(set! (var-history v) (cons form (var-history v)))))))
- form)
-
- (if (and *report-any-!-as-setter* ; (inc! x) when inc! is unknown, assume it sets x
- (symbol? (car form))
- (pair? (cdr form))
- (symbol? (cadr form))
- (not (var-member (car form) env))
- (not (hash-table-ref built-in-functions (car form)))
- (let ((str (symbol->string (car form))))
- (char=? (string-ref str (- (length str) 1)) #\!)))
+ form)
+
+ (if (set!? form env)
(set-set (cadr form) caller form env)))
-
- (if (not (var? v))
- (check-special-cases caller head form env)
+
+ (if (var? v)
(if (and (memq (var-ftype v) '(define lambda define* lambda*))
(not (memq caller (var-scope v))))
(let ((cv (var-member caller env)))
@@ -13292,28 +15282,56 @@
(memq (var-ftype cv) '(define lambda define* lambda*))) ; named-let does not define ftype
caller
(cons caller env))
- (var-scope v))))))
-
- (if (assq head deprecated-ops)
- (lint-format "~A is deprecated; use ~A" caller head (cond ((assq head deprecated-ops) => cdr))))
-
- (if (and (not (= line-number last-simplify-numeric-line-number))
- (not (var? v))
- (hash-table-ref numeric-ops head)
- (proper-tree? form))
- (let ((val (simplify-numerics form env)))
- (if (not (equal-ignoring-constants? form val))
- (begin
- (set! last-simplify-numeric-line-number line-number)
- (lint-format "perhaps ~A" caller (lists->string form val))))))
-
+ (var-scope v)))))
+ (begin
+ (cond ((hash-table-ref special-case-functions head)
+ => (lambda (f)
+ (f caller head form env))))
+
+ ;; change (list ...) to '(....) if it's safe as a constant list
+ ;; and (vector ...) -> #(...)
+ (if (and (pair? (cdr form))
+ (hash-table-ref no-side-effect-functions head)
+ (not (memq head unsafe-makers)))
+ (do ((p (cdr form) (cdr p)))
+ ((not (pair? p)))
+ (if (let constable? ((cp (car p)))
+ (and (pair? cp)
+ (memq (car cp) '(list vector))
+ (pair? (cdr cp))
+ (every? (lambda (inp)
+ (or (code-constant? inp)
+ (constable? inp)))
+ (cdr cp))))
+ (lint-format "perhaps ~A -> ~A~A" caller
+ (truncated-list->string (car p))
+ (if (eq? (caar p) 'list) "'" "")
+ (object->string (eval (car p)))))))
+
+ (if (and (not (= line-number last-simplify-numeric-line-number))
+ (hash-table-ref numeric-ops head)
+ (proper-tree? form))
+ (let ((val (simplify-numerics form env)))
+ (if (not (equal-ignoring-constants? form val))
+ (begin
+ (set! last-simplify-numeric-line-number line-number)
+ (lint-format "perhaps ~A" caller (lists->string form val))))))
+
+ ;; if a var is used before it is defined, the var history and ref/set
+ ;; info needs to be saved until the definition, so other-identifiers collects it
+ (unless (defined? head (rootlet))
+ (hash-table-set! other-identifiers head
+ (if (not (hash-table-ref other-identifiers head))
+ (list form)
+ (cons form (hash-table-ref other-identifiers head)))))))
+
;; ----------------
;; (f ... (if A B C) (if A D E) ...) -> (f ... (if A (values B D) (values C E)) ...)
;; these happen up to almost any number of clauses
;; need true+false in every case, and need to be contiguous
;; case/cond happen here, but very rarely in a way we can combine via values
-
- (unless (any-macro? (car form) env) ; actually most macros are safe here...
+
+ (unless (any-macro? head env) ; actually most macros are safe here...
(let ((p (member 'if (cdr form) (lambda (x q)
(and (pair? q)
(eq? (car q) 'if) ; it's an if expression
@@ -13349,88 +15367,126 @@
(if (side-effect? test env)
(format #f " (ignoring ~S's possible side-effects)" test)
"")
- (lists->string form `(, at header ,middle , at q)))))))))))
- ;; ----------------
-
- ;; if a var is used before it is defined, the var history and ref/set
- ;; info needs to be saved until the definition, so other-identifiers collects it
- (unless (or (var? v)
- (defined? head (rootlet)))
- (hash-table-set! other-identifiers head
- (if (not (hash-table-ref other-identifiers head))
- (list form)
- (cons form (hash-table-ref other-identifiers head)))))))
-
- ;; `(,(car x) ,@(cdr x)) -> ,x ({list} (car x) ({apply_values} (cdr x))) -- almost never happens
-
- (when (and (pair? head)
- (pair? (cdr head))
- (memq (car head) '(lambda lambda*)))
- (cond ((and (identity? head)
- (pair? (cdr form))) ; identity needs an argument
- (lint-format "perhaps ~A" caller (truncated-lists->string form (cadr form))))
-
- ((and (null? (cadr head))
- (pair? (cddr head)))
- (lint-format "perhaps ~A" caller
- (truncated-lists->string
- form
- (if (and (null? (cdddr head))
- (not (and (pair? (caddr head))
- (memq (caaddr head) '(define define* define-constant define-macro define-macro*)))))
- (caddr head)
- `(let () ,@(cddr head))))))
-
- ((and (pair? (cddr head)) ; ((lambda (...) ...) ...) -> (let ...) -- lambda here is ugly and slow
- (proper-list? (cddr head))
- (not (any? (lambda (a) (mv-range a env)) (cdr form))))
- (call-with-exit
- (lambda (quit) ; uncountably many things can go wrong with the lambda form
- (let ((vars ())
- (vals ()))
- (do ((v (cadr head) (cdr v))
- (a (cdr form) (cdr a)))
- ((not (and (pair? a)
- (pair? v)))
- (if (symbol? v)
- (begin
- (set! vars (cons v vars))
- (set! vals (cons `(list , at a) vals)))
- (do ((v v (cdr v)))
- ((not (pair? v)))
- (if (not (pair? v))
- (quit))
- (if (pair? (car v))
- (begin
- (if (not (pair? (cdar v)))
- (quit))
- (set! vars (cons (caar v) vars))
- (set! vals (cons (cadar v) vals)))
- (begin
- (set! vars (cons (car v) vars))
- (set! vals (cons #f vals)))))))
- (set! vars (cons (if (pair? (car v)) (caar v) (car v)) vars))
- (set! vals (cons (car a) vals)))
-
- (lint-format "perhaps ~A" caller
- (lists->string form
- `(,(if (or (eq? (car head) 'lambda)
- (not (pair? (cadr head)))
- (null? (cdadr head)))
- 'let 'let*)
- ,(map list (reverse vars) (reverse vals))
- ,@(cddr head))))))))))
- (let ((vars env))
- (for-each
- (lambda (f)
- (set! vars (lint-walk caller f vars)))
- form))))
- env))))))))
+ (lists->string form `(, at header ,middle , at q)))))))))))))
+ ((pair? head)
+ (when (and (pair? (cdr head))
+ (memq (car head) '(lambda lambda*)))
+ (cond ((and (identity? head)
+ (pair? (cdr form))) ; identity needs an argument
+ (lint-format "perhaps ~A" caller (truncated-lists->string form (cadr form))))
+
+ ((and (null? (cadr head))
+ (pair? (cddr head)))
+ (lint-format "perhaps ~A" caller
+ (truncated-lists->string
+ form
+ (if (and (null? (cdddr head))
+ (not (and (pair? (caddr head))
+ (memq (caaddr head) '(define define* define-constant define-macro define-macro*)))))
+ (caddr head)
+ `(let () ,@(cddr head))))))
+
+ ((and (pair? (cddr head)) ; ((lambda (...) ...) ...) -> (let ...) -- lambda here is ugly and slow
+ (proper-list? (cddr head))
+ (not (any? (lambda (a) (mv-range a env)) (cdr form))))
+ (call-with-exit
+ (lambda (quit) ; uncountably many things can go wrong with the lambda form
+ (let ((vars ())
+ (vals ()))
+ (do ((v (cadr head) (cdr v))
+ (a (cdr form) (cdr a)))
+ ((not (and (pair? a)
+ (pair? v)))
+ (if (symbol? v)
+ (begin
+ (set! vars (cons v vars))
+ (set! vals (cons `(list , at a) vals)))
+ (do ((v v (cdr v)))
+ ((not (pair? v)))
+ (if (not (pair? v))
+ (quit))
+ (if (pair? (car v))
+ (begin
+ (if (not (pair? (cdar v)))
+ (quit))
+ (set! vars (cons (caar v) vars))
+ (set! vals (cons (cadar v) vals)))
+ (begin
+ (set! vars (cons (car v) vars))
+ (set! vals (cons #f vals)))))))
+ (set! vars (cons ((if (pair? (car v)) caar car) v) vars))
+ (set! vals (cons (car a) vals)))
+
+ (lint-format "perhaps ~A" caller
+ (lists->string form
+ `(,(if (or (eq? (car head) 'lambda)
+ (not (pair? (cadr head)))
+ (null? (cdadr head)))
+ 'let 'let*)
+ ,(map list (reverse vars) (reverse vals))
+ ,@(cddr head)))))))))))
+
+ ((and (procedure? head)
+ (memq head '(#_{list} #_{apply_values} #_{append})))
+ (for-each (lambda (p)
+ (if (quoted-symbol? p)
+ (let* ((sym (cadr p))
+ (v (var-member sym env)))
+ (if (var? v)
+ (set-ref sym caller form env)
+ (if (not (defined? sym (rootlet)))
+ (hash-table-set! other-identifiers sym
+ (if (not (hash-table-ref other-identifiers sym))
+ (list form)
+ (cons form (hash-table-ref other-identifiers sym)))))))))
+ (cdr form))))
+ ;; here forms like `(x , at y) could be rewritten as (cons 'x y) but is that an improvement?
+
+ (let ((vars env))
+ (for-each
+ (lambda (f)
+ (set! vars (lint-walk caller f vars)))
+ form))))
+ env))))))
+
+ (define (lint-walk caller form env)
+ (cond ((symbol? form)
+ (if (memq form '(+i -i))
+ (format outport "~NC~A is not a number in s7~%" lint-left-margin #\space form))
+ (set-ref form caller #f env)) ; returns env
+
+ ((pair? form)
+ (lint-walk-pair caller form env))
+
+ ((string? form)
+ (let ((len (length form)))
+ (if (and (> len 16)
+ (string=? form (make-string len (string-ref form 0))))
+ (lint-format "perhaps ~S -> ~A" caller form `(format #f "~NC" ,len ,(string-ref form 0)))))
+ env)
+
+ ((vector? form)
+ (let ((happy #t))
+ (for-each
+ (lambda (x)
+ (when (and (pair? x)
+ (eq? (car x) 'unquote))
+ (lint-walk caller (cadr x) env) ; register refs
+ (set! happy #f)))
+ form)
+ (if (not happy) ; these are used exactly 4 times (in a test suite!) in 2 million lines of open source scheme code
+ (lint-format "quasiquoted vectors are not supported: ~A" caller form)))
+ ;; `(x #(,x)) for example will not work in s7, but `(,x ,(vector x)) will
+ env)
+
+ (else
+ env)))
+
;; -------- lint-file --------
(define *report-input* #t)
-
+
(define (lint-file-1 file env)
(set! linted-files (cons file linted-files))
(let ((fp (if (input-port? file)
@@ -13532,17 +15588,17 @@
(if (positive? (length *current-file*))
(newline outport)))))))
-
;;; --------------------------------------------------------------------------------'
;;; lint itself
;;;
(let ((documentation "(lint file port) looks for infelicities in file's scheme code")
(signature (list #t string? output-port? boolean?)))
- (lambda* (file (outp *lint-output-port*) (report-input #t))
+ (lambda* (file (outp *output-port*) (report-input #t))
(set! outport outp)
(set! other-identifiers (make-hash-table))
(set! linted-files ())
+ (fill! other-names-counts 0)
(set! last-simplify-boolean-line-number -1)
(set! last-simplify-numeric-line-number -1)
(set! last-simplify-cxr-line-number -1)
@@ -13550,7 +15606,6 @@
(set! last-cons-line-number -1)
(set! last-if-line-number -1)
(set! last-rewritten-internal-define #f)
- (set! last-assoc-form #f)
(set! line-number -1)
(set! quote-warnings 0)
(set! pp-left-margin 0)
@@ -13599,8 +15654,11 @@
(cons #\, (lambda (str) ; the same, the last is #,@ -> unsyntax-splicing -- right.
(list 'unsyntax (if (string=? str "'") (read) (string->symbol str)))))
+ (cons #\& (lambda (str) ; ancient Guile code
+ (make-keyword (substring str 1))))
+
(cons #\! (lambda (str)
- (if (member str '("!optional" "!default" "!rest" "!key" "!aux" "!false" "!true") string-ci=?) ; for MIT-scheme
+ (if (member str '("!optional" "!default" "!rest" "!key" "!aux" "!false" "!true" "!r6rs") string-ci=?) ; for MIT-scheme
(make-keyword (substring str 1))
(let ((lc (str 0))) ; s7 should handle this, but...
(do ((c (read-char) (read-char)))
@@ -13629,7 +15687,7 @@
((#\;) (read) (values))
((#\T) (string=? data "T"))
- ((#\F) (and (string=? data "F") (list 'quote #f)))
+ ((#\F) (and (string=? data "F") ''#f))
((#\X)
(let ((num (string->number (substring data 1)))) ; mit-scheme, maybe others
(if (number? num)
@@ -13651,6 +15709,7 @@
(format outport "~NCuse #<unspecified>, not #unspecified~%" lint-left-margin #\space))
;; #<unspecified> seems to hit the no-values check?
(string->symbol data))
+ ;; Bigloo also seems to use #" for here-doc concatenation??
((#\v) ; r6rs byte-vectors?
(if (string=? data "vu8")
@@ -13691,6 +15750,10 @@
("\\delete" . #\delete)
("\\backspace" . #\backspace)
("\\page" . #\xc)
+ ("\\altmode" . #\escape)
+ ("\\bel" . #\alarm) ; #\x07
+ ("\\sub" . #\x1a)
+ ("\\soh" . #\x01)
;; rest are for Guile
("\\vt" . #\xb)
@@ -13775,7 +15838,7 @@
(epos (string-position "<em " str)))
(if (not (or apos epos))
str
- (let* ((pos (if (and apos epos) (min apos epos) (or apos epos)))
+ (let* ((pos ((if (and apos epos) min or) apos epos))
(bpos (char-position #\> str (+ pos 1)))
(epos (string-position (if (and apos (= pos apos)) "</a>" "</em>") str (+ bpos 1))))
(string-append (substring str 0 pos)
@@ -13814,7 +15877,7 @@
(rline 1 (+ rline 1)))
((string-position "</pre>" cline)
(set! line-num (+ line-num rline)))
- (set! code (string-append code cline)))
+ (set! code (string-append code cline)))
;; is first non-whitespace char #\(? ignoring comments
(let ((len (length code)))
@@ -13837,7 +15900,7 @@
(call-with-input-string (format #f "~S" ncode)
(lambda (ip)
(let-temporarily ((*report-shadowed-variables* #t))
- (lint ip op #f))))))))
+ (lint ip op #f))))))))
(if (> (length outstr) 1) ; possible newline at end
(format () ";~A ~D: ~A~%" file line-num outstr))))
(lambda args
@@ -13901,64 +15964,52 @@
;;; --------------------------------------------------------------------------------
-;;; this sends lint's output to the Snd repl's widget
-
-(define (snd-lint file)
- (lint file (openlet
- (inlet :name "lint-output-port"
- :format (lambda (p str . args) (snd-print (apply format #f str args)))
- :write (lambda (obj p) (snd-print (object->string obj #t)))
- :display (lambda (obj p) (snd-print (object->string obj #f)))
- :write-string (lambda (str p) (snd-print str))
- :write-char (lambda (ch p) (snd-print (string ch)))
- :newline (lambda (p) (snd-print (string #\newline)))
- :close-output-port (lambda (p) #f)
- :flush-output-port (lambda (p) #f)))))
-
#|
;;; external use of lint contents:
(for-each (lambda (f)
(if (not (hash-table-ref (*lint* 'no-side-effect-functions) (car f)))
(format *stderr* "~A " (car f))))
(*lint* 'built-in-functions))
-|#
-#|
;;; get rid of []'s! (using Snd)
(define (edit file)
- (let ((str (file->string file)))
- (let ((len (length str)))
- (do ((i 0 (+ i 1)))
- ((= i len))
- (case (str i)
- ((#\]) (set! (str i) #\)))
- ((#\[) (set! (str i) #\()))))
+ (let* ((str (file->string file))
+ (len (length str)))
+ (do ((i 0 (+ i 1)))
+ ((= i len))
+ (case (str i)
+ ((#\]) (set! (str i) #\)))
+ ((#\[) (set! (str i) #\())))
(call-with-output-file file
(lambda (p)
- (display str p)))))
+ (display str p)))
+ #f))
|#
;;; --------------------------------------------------------------------------------
;;; TODO:
;;;
;;; code-equal if/when/unless/cond, case: any order of clauses, let: any order of vars, etc, zero/=0
-;;; snd-lint: load lint, add to various hash-tables via *lint* [if provided? 'snd load snd-lint.scm or something]
;;; auto unit tests, *report-tests* -> list of funcs to test as in zauto, possibly fix errors
;;; indentation is confused in pp by if expr+values?, pp handling of (list ((lambda...)..)) is bad
;;; there are now lots of cases where we need to check for values (/ as invert etc)
-;;; x used as number then (if x...) or (and (vector-ref 0) (string-length (vector-ref 0)))
;;; the ((lambda ...)) -> let rewriter is still tricked by values
+;;; c-side type checkers need ways to merge into lint's type compatibilty checks (mus-generator etc)
+;;; for scope calc, each macro call needs to be expanded or use out-vars?
+;;; if we know a macro's value, expand via macroexpand each time encountered and run lint on that? [see 10983 for expansion]
+;;;
+;;; argument consistency? (vector (number? x) (< x 0))
+;;; one arg assumes type, other either assumes a different type or tests for something not subsumed in the first
+;;; define-macro cases in t347?? [10983]
+;;; eq?/=/any-sig extension of and-forgetful
+;;; if big arg is already let, perhaps use body as replacement
+;;; why was the large repeated let ignored?
+;;; there are 473 Snd functions without signatures; how to handle unsafe functions/dilambdas?
+;;; internal (mid body) define? [9630], also in open bodies -- begin primarily?
+;;; localized var (to extent possible?) if set! always precedes use: set!->let
+;;; var-hist: init[refs...] set![refs all in set! context...] set![refs]
+;;; var 2 values, vals themselves arbitrary (0/1) -> booleans
+;;; if combinations: check entire and exprs for intersection
+;;; the let-temp rewrite needs to be at the set points [13900]
;;;
-;;; lambda (define? named-let?) constant seqs -> closure? what about others similar (sqrt2 (sqrt 2))...? [9792]
-;;; (let ((A (f x)) (let ((B (g A))) <no use of A>...))) or let* -> (let ((B (g (f x))))?
-;;; see member/string= case in t347 -- smarter cond -> assoc code needed
-;;; also reversed order (eq? 'a x) (eq? 'b x) etc (reorder either way)
-;;; also need code-equal for cond test repetition check (or at least reversible check -- this works in or/and I think)
-;;; and the rewrite looks nutty -- (#f 4)!
-;;; */- are reversible after first
-;;; infinite? -> +/-inf.0 in cond->case? or does this require real? nan.0 isn't eqv? so can't work in case?
-;;; pi also should be ok and most-positive|negative-fixnum but each requires the actual number -- won't work for pi: #_pi?
-;;; case with #_abs etc?
-;;; case with all results (f ...) does happen (else being an error)
-;;;
-;;; 114 22113 433088
+;;; 134 23101 551064
diff --git a/marks-menu.scm b/marks-menu.scm
index 30708e7..5fee886 100644
--- a/marks-menu.scm
+++ b/marks-menu.scm
@@ -34,9 +34,7 @@
(define find-two-marks
(let ((documentation "(find-two-marks) looks for the marks for the marks-menu functions to use"))
(lambda ()
- (let* ((snd (selected-sound))
- (chn (selected-channel))
- (ms (marks snd chn)))
+ (let ((ms (marks (selected-sound) (selected-channel))))
(if (> (length ms) 1)
(map mark->integer (list (car ms) (cadr ms)))
(list))))))
@@ -261,7 +259,7 @@
XmNbottomAttachment XmATTACH_FORM
XmNlabelString s1
XmNbackground *basic-color*)))
- (buffer-labels (map XmStringCreateLocalized (list "64" "128" "256" "512" "1024" "2048" "4096")))
+ (buffer-labels (map XmStringCreateLocalized '("64" "128" "256" "512" "1024" "2048" "4096")))
(combo (XtCreateManagedWidget "buffersize" xmComboBoxWidgetClass frm
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget lab
@@ -322,7 +320,7 @@
XmNset (= size loop-between-marks-buffer-size)))))
(if (= size loop-between-marks-buffer-size)
(set! loop-between-marks-default-buffer-widget button))))
- (list 64 128 256 512 1024 2048 4096))
+ '(64 128 256 512 1024 2048 4096))
(XmStringFree s1)))))
(activate-dialog loop-between-marks-dialog))
@@ -417,9 +415,9 @@
(define cp-fit-to-marks
(let ((documentation "(cp-fit-to-marks) fits the selection between two marks (marks-menu)"))
(lambda ()
- (if (selection?)
- (fit-selection-between-marks (integer->mark fit-to-mark-one) (integer->mark fit-to-mark-two))
- (define-selection-via-marks (integer->mark fit-to-mark-one) (integer->mark fit-to-mark-two))))))
+ ((if (selection?) fit-selection-between-marks define-selection-via-marks)
+ (integer->mark fit-to-mark-one)
+ (integer->mark fit-to-mark-two)))))
(if (not (or (provided? 'xm)
(provided? 'xg)))
@@ -844,7 +842,7 @@ between two marks,using the granulate generator to fix up the selection duration
(set! (loop-data (+ loc (* offset 2))) (max ml (- (loop-data (+ loc (* offset 2))) 1)))
(update-labels midlab1 midlab2 midlab3 offset range-in-secs))))))
(list rowlefttop rowleftbottom)
- (list 0 1))
+ '(0 1))
(for-each
(lambda (rparent loc)
@@ -874,11 +872,11 @@ between two marks,using the granulate generator to fix up the selection duration
(set! (loop-data (+ loc (* offset 2))) ml)
(update-labels midlab1 midlab2 midlab3 offset range-in-secs)))))))
(list rowrighttop rowrightbottom)
- (list 0 1))))
+ '(0 1))))
(list leftform rightform)
- (list "Sustain" "Release")
- (list 0 1)))
+ '("Sustain" "Release")
+ '(0 1)))
(for-each-child
loop-dialog
(lambda (n)
@@ -891,8 +889,7 @@ between two marks,using the granulate generator to fix up the selection duration
(XtVaSetValues n (list XmNselectColor
(let* ((col (XColor))
(dpy (XtDisplay (cadr (main-widgets))))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(XAllocNamedColor dpy cmap "yellow" col col)
(.pixel col)))))))))
))
diff --git a/marks.scm b/marks.scm
index 14b07c4..df6f2cc 100644
--- a/marks.scm
+++ b/marks.scm
@@ -236,28 +236,26 @@
(lambda ()
(hook-push start-playing-hook
(lambda (snd)
- (let ((marklist (marks snd 0)))
-
- (define report-mark-names-play-hook
- (let ((samplist (map mark-sample marklist))
- (samp 0))
- (lambda (hook)
- (set! samp (+ samp (hook 'size)))
- (if (and (pair? samplist)
- (>= samp (car samplist)))
- (begin
- (status-report (mark-name (car marklist)) snd)
- (set! marklist (cdr marklist))
- (set! samplist (cdr samplist)))))))
-
- (define (report-mark-names-stop-playing-hook hook)
- (status-report "" (hook 'snd))
- (hook-remove play-hook report-mark-names-play-hook)
- (hook-remove stop-playing-hook report-mark-names-stop-playing-hook))
-
- (hook-push stop-playing-hook report-mark-names-stop-playing-hook)
- (hook-push play-hook report-mark-names-play-hook)
- #f))))))
+ (let* ((marklist (marks snd 0))
+ (report-mark-names-play-hook
+ (let ((samplist (map mark-sample marklist))
+ (samp 0))
+ (lambda (hook)
+ (set! samp (+ samp (hook 'size)))
+ (if (and (pair? samplist)
+ (>= samp (car samplist)))
+ (begin
+ (status-report (mark-name (car marklist)) snd)
+ (set! marklist (cdr marklist))
+ (set! samplist (cdr samplist))))))))
+ (letrec ((report-mark-names-stop-playing-hook
+ (lambda (hook)
+ (status-report "" (hook 'snd))
+ (hook-remove play-hook report-mark-names-play-hook)
+ (hook-remove stop-playing-hook report-mark-names-stop-playing-hook))))
+ (hook-push stop-playing-hook report-mark-names-stop-playing-hook)
+ (hook-push play-hook report-mark-names-play-hook)
+ #f)))))))
;;; -------- snap-marks
@@ -357,16 +355,9 @@
(define save-mark-properties
(let ((documentation "(save-mark-properties) sets up an after-save-state-hook function to save any mark-properties"))
(lambda ()
-
- (define (open-appending filename)
- (open-output-file filename "a"))
-
- (define close-appending close-output-port)
-
(hook-push after-save-state-hook
(lambda (hook)
- (let* ((filename (hook 'name))
- (fd (open-appending filename)))
+ (let ((fd (open-output-file (hook 'name) "a")))
(format fd "~%~%;;; from remember-mark-properties in marks.scm~%")
(format fd "(if (not (defined? 'mark-property)) (load \"marks.scm\"))~%")
(for-each
@@ -387,7 +378,7 @@
chn-m))
snd-m))
(marks))
- (close-appending fd)))))))
+ (close-output-port fd)))))))
(define mark-click-info
diff --git a/maxf.scm b/maxf.scm
index b83a9e8..d760729 100644
--- a/maxf.scm
+++ b/maxf.scm
@@ -43,10 +43,8 @@
(define *locsig-type* mus-interp-sinusoidal)
(define (snd-msg frm . args)
- (let ((str (apply format #f frm args)))
- (if (getenv "EMACS")
- (display str)
- (snd-print str))))
+ ((if (not (string=? "" (getenv "EMACS"))) display snd-print)
+ (apply format #f frm args)))
(defgenerator mvm sample pp1 pp2 pp3 yy1 yy2 zz1 zz2 out)
diff --git a/misc.scm b/misc.scm
index fc20303..018110d 100644
--- a/misc.scm
+++ b/misc.scm
@@ -164,9 +164,7 @@
(XtAddEventHandler rename-text LeaveWindowMask #f
(lambda (w context ev flag)
(XtSetValues w (list XmNbackground *basic-color*)))))))
- (if (not (XtIsManaged rename-dialog))
- (XtManageChild rename-dialog)
- (raise-dialog rename-dialog)))
+ ((if (not (XtIsManaged rename-dialog)) XtManageChild raise-dialog) rename-dialog))
8)))
(install-searcher-with-colors (lambda (file) #t))
diff --git a/mix.scm b/mix.scm
index cacc461..5871db5 100644
--- a/mix.scm
+++ b/mix.scm
@@ -75,8 +75,7 @@
(define (snap-mix-1 id samps-moved)
(let* ((samp (+ samps-moved (mix-position id)))
(snd (car (mix-home id)))
- (chn (cadr (mix-home id)))
- (bps (/ (beats-per-minute snd chn) 60.0))
+ (bps (/ (beats-per-minute snd (cadr (mix-home id))) 60.0))
(sr (srate snd))
(beat (floor (/ (* samp bps) sr)))
(lower (floor (/ (* beat sr) bps)))
@@ -96,8 +95,7 @@
(define (snap-syncd-mixes-1 id samps-moved)
(let* ((samp (+ samps-moved (mix-position id)))
(snd (car (mix-home id)))
- (chn (cadr (mix-home id)))
- (bps (/ (beats-per-minute snd chn) 60.0))
+ (bps (/ (beats-per-minute snd (cadr (mix-home id))) 60.0))
(sr (srate snd))
(beat (floor (/ (* samp bps) sr)))
(lower (floor (/ (* beat sr) bps)))
@@ -147,9 +145,9 @@ All mixes sync'd to it are also moved the same number of samples. (hook-remove m
(lambda (n)
(help-dialog "Mix Help"
(format #f "Mix ~A (sync: ~A):~% position: ~D = ~,3F secs~% length: ~D (~,3F secs)~% in: ~A[~D]~% scaler: ~A~% speed: ~A~% env: ~A~A"
- (format #f (if (mix-name n)
- (values "~S (~A)" (mix-name n) n)
- (values "~A" n)))
+ (format #f (if (string=? (mix-name n) "")
+ (values "~A" n)
+ (values "~S (~A)" (mix-name n) n)))
(mix-sync n)
(mix-position n)
(* 1.0 (/ (mix-position n) (srate (car (mix-home n)))))
@@ -182,8 +180,7 @@ All mixes sync'd to it are also moved the same number of samples. (hook-remove m
((= chn (channels snd)))
(for-each
(lambda (m)
- (if (and (string? (mix-name m))
- (string=? (mix-name m) name))
+ (if (equal? (mix-name m) name)
(return m)))
(mixes snd chn))))
(sounds))
@@ -316,10 +313,11 @@ may change)"))
(let ((documentation "(mixes-length mix-list) returns the number of samples between the start of the earliest mix and the \
last end of the mixes in 'mix-list'"))
(lambda (mix-list)
- (+ 1 (- (apply max (map (lambda (m)
- (+ (mix-position m) (framples m)))
- mix-list))
- (apply min (map mix-position mix-list)))))))
+ (- (+ (apply max (map (lambda (m)
+ (+ (mix-position m) (framples m)))
+ mix-list))
+ 1)
+ (apply min (map mix-position mix-list))))))
(define env-mixes
@@ -331,7 +329,7 @@ last end of the mixes in 'mix-list'"))
(end (apply max mix-ends))
(first-x (car overall-amp-env))
(last-x (envelope-last-x overall-amp-env))
- (x-scale (/ (- last-x first-x) (+ 1 (- end beg)))))
+ (x-scale (/ (- last-x first-x) (- (+ end 1) beg))))
(as-one-edit
(lambda ()
(for-each
@@ -426,8 +424,7 @@ panning operation."))
(define (invert-envelope e)
(if (null? e)
()
- (append (list (car e) (- 1.0 (cadr e)))
- (invert-envelope (cddr e)))))
+ (cons (car e) (cons (- 1.0 (cadr e)) (invert-envelope (cddr e))))))
(let ((incoming-chans (channels name))
(receiving-chans (channels index)))
@@ -440,7 +437,8 @@ panning operation."))
;; mono to mono = just scale or envelope
(let ((idx (mix name beg 0 index 0 *with-mix-tags* auto-delete))) ; file start in-chan snd chn ...
- (and idx (mix? (car idx))
+ (and (pair? idx)
+ (mix? (car idx))
(let ((id (car idx)))
(set! (mix-amp-env id) (invert-envelope pan))
idx)))
@@ -448,8 +446,10 @@ panning operation."))
;; mono to stereo
(let ((idx0 (mix name beg 0 index 0 *with-mix-tags* deletion-choice))
(idx1 (mix name beg 0 index 1 *with-mix-tags* end-deletion-choice)))
- (and idx0 (mix? (car idx0))
- idx1 (mix? (car idx1))
+ (and (pair? idx0)
+ (mix? (car idx0))
+ (pair? idx1)
+ (mix? (car idx1))
(let ((id0 (car idx0))
(id1 (car idx1)))
(set! (mix-amp-env id0) (invert-envelope pan))
@@ -463,8 +463,10 @@ panning operation."))
;; stereo -> mono => scale or envelope both input chans into the output
(let ((idx0 (mix name beg 0 index 0 *with-mix-tags* deletion-choice))
(idx1 (mix name beg 1 index 0 *with-mix-tags* end-deletion-choice)))
- (and idx0 (mix? (car idx0))
- idx1 (mix? (car idx1))
+ (and (pair? idx0)
+ (mix? (car idx0))
+ (pair? idx1)
+ (mix? (car idx1))
(let ((id0 (car idx0))
(id1 (car idx1)))
(set! (mix-amp-env id0) (invert-envelope pan))
@@ -477,10 +479,14 @@ panning operation."))
(idx10 (mix name beg 1 index 0 *with-mix-tags* deletion-choice))
(idx11 (mix name beg 1 index 1 *with-mix-tags* end-deletion-choice)))
- (and idx00 (mix? (car idx00))
- idx01 (mix? (car idx01))
- idx10 (mix? (car idx10))
- idx11 (mix? (car idx11))
+ (and (pair? idx00)
+ (mix? (car idx00))
+ (pair? idx01)
+ (mix? (car idx01))
+ (pair? idx10)
+ (mix? (car idx10))
+ (pair? idx11)
+ (mix? (car idx11))
(let ((id00 (car idx00))
(id01 (car idx01))
(id10 (car idx10))
diff --git a/mockery.scm b/mockery.scm
index c5c5d5c..82a14f6 100644
--- a/mockery.scm
+++ b/mockery.scm
@@ -55,7 +55,7 @@
'sort! (lambda (obj f) (#_sort! (obj 'value) f))
'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
'arity (lambda (obj) (#_arity (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-vector*" "#<mock-vector-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-vector*" "#<mock-vector-class>")))
'vector-dimensions (lambda (obj) (#_vector-dimensions (obj 'value)))
'fill! (lambda (obj val) (#_fill! (obj 'value) val))
@@ -182,7 +182,7 @@
'fill! (lambda (obj val) (#_fill! (obj 'mock-hash-table-table) val))
'reverse (lambda (obj) (#_reverse (obj 'mock-hash-table-table)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-hash-table*" "#<mock-hash-table-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-hash-table*" "#<mock-hash-table-class>")))
'arity (lambda (obj) (#_arity (obj 'mock-hash-table-table)))
'copy (lambda* (source dest . args)
(if (mock-hash-table? source)
@@ -265,7 +265,7 @@
(openlet
(inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
'reverse (lambda (obj) (#_reverse (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-string*" "#<mock-string-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-string*" "#<mock-string-class>")))
'arity (lambda (obj) (#_arity (obj 'value)))
'make-iterator (lambda (obj) (#_make-iterator (obj 'value)))
'let-ref (lambda (obj i) (#_string-ref (obj 'value) i)) ; these are the implicit cases
@@ -439,7 +439,7 @@
'char-ci<=? (make-local-method #_char-ci<=?)
'char-ci>=? (make-local-method #_char-ci>=?)
'string (make-local-method #_string)
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-char*" "#<mock-char-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-char*" "#<mock-char-class>")))
'arity (lambda (obj) (#_arity (obj 'value)))
'format (make-local-method #_format)
'make-string (make-local-method #_make-string)
@@ -518,7 +518,7 @@
(openlet
(inlet
'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-number*" "#<mock-number-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-number*" "#<mock-number-class>")))
'arity (lambda (obj) (#_arity (obj 'value)))
'real-part (lambda (obj) (#_real-part (obj 'value)))
'imag-part (lambda (obj) (#_imag-part (obj 'value)))
@@ -857,7 +857,7 @@
(inlet 'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
'pair-line-number (lambda (obj) (#_pair-line-number (obj 'value)))
'list->string (lambda (obj) (#_list->string (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-pair*" "#<mock-pair-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-pair*" "#<mock-pair-class>")))
'list? (lambda (obj) (#_list? (obj 'value)))
'car (lambda (obj) (#_car (obj 'value)))
'cdr (lambda (obj) (#_cdr (obj 'value)))
@@ -996,7 +996,7 @@
(define *mock-symbol*
(let ((mock-symbol-class
(openlet
- (inlet 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-symbol*" "#<mock-symbol-class>"))
+ (inlet 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-symbol*" "#<mock-symbol-class>")))
'morally-equal? (lambda (x y) (#_morally-equal? (x 'value) y))
'gensym? (lambda (obj) (#_gensym? (obj 'value)))
'symbol->string (lambda (obj) (#_symbol->string (obj 'value)))
@@ -1057,7 +1057,7 @@
'char-ready? (lambda (obj) (#_char-ready? (obj 'value)))
'port-line-number (lambda (obj) (#_port-line-number (obj 'value)))
'port-filename (lambda (obj) (#_port-filename (obj 'value)))
- 'object->string (lambda* (obj (w #t)) (if (eq? w :readable) "*mock-port*" "#<mock-port-class>"))
+ 'object->string (lambda* (obj (w #t)) (copy (if (eq? w :readable) "*mock-port*" "#<mock-port-class>")))
'format (make-local-method #_format)
'set-current-output-port (lambda (obj) (#_set-current-output-port (obj 'value)))
diff --git a/musglyphs.scm b/musglyphs.scm
index b219948..e04bf87 100644
--- a/musglyphs.scm
+++ b/musglyphs.scm
@@ -5,6 +5,8 @@
;;;
;;; although Snd based here, all this file needs externally are draw-lines, draw-dot, and fill-polygon
+;;; currently this works only in Motif
+
(provide 'snd-musglyphs.scm)
(define make-polygon
@@ -14,7 +16,9 @@
((vector? (car vects)) (total-length (cdr vects) (+ len (length (car vects)))))
((car vects) (total-length (cdr vects) (+ len 1)))
(else (total-length (cdr vects) len))))
- (define (set-vals vects start vals)
+ (let set-vals ((vects args)
+ (start 0)
+ (vals (make-vector (total-length args 0))))
(cond ((null? vects) vals)
((vector? (car vects))
(let* ((vect (car vects))
@@ -26,8 +30,7 @@
((car vects)
(set! (vals start) (car vects))
(set-vals (cdr vects) (+ start 1) vals))
- (else (set-vals (cdr vects) start vals))))
- (set-vals args 0 (make-vector (total-length args 0)))))
+ (else (set-vals (cdr vects) start vals))))))
(define (make-bezier-1 x0 y0 x1 y1 x2 y2 x3 y3 n)
;; creates a line-segment approximation of a bezier curve: n = number of segments
@@ -106,38 +109,79 @@
(set! pathlist (cons v pathlist))
#f))
-(define* (fill-in score :rest args)
- (if (pair? pathlist)
- (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
- (fill-polygon
- (make-polygon
- (reverse pathlist))
- ps-snd ps-chn ps-ax cr)
- (free-cairo cr)))
- (set! pathlist ())
- #f)
-
-(define (draw score arg)
- (if (pair? pathlist)
- (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
- (draw-lines
- (make-polygon
- (reverse pathlist))
- ps-snd ps-chn ps-ax cr)
- (free-cairo cr)))
- (set! pathlist ())
- #f)
-
-(define (circle score x0 y0 rad . rest)
- (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
- (draw-dot (->x x0) (->y y0)
- (floor (* ps-size rad 2))
- ps-snd ps-chn ps-ax cr)
- (free-cairo cr)))
-
-(define-macro (defvar name value) `(define ,name ,value))
-
-(define-macro (setf a b) `(set! ,a ,b))
+(if (provided? 'snd-gtk)
+ (begin
+ (define* (fill-in score :rest args)
+ (if (pair? pathlist)
+ (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
+ (fill-polygon
+ (make-polygon
+ (reverse pathlist))
+ ps-snd ps-chn ps-ax cr)
+ (free-cairo cr)))
+ (set! pathlist ())
+ #f)
+
+ (define (draw score arg)
+ (if (pair? pathlist)
+ (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
+ (draw-lines
+ (make-polygon
+ (reverse pathlist))
+ ps-snd ps-chn ps-ax cr)
+ (free-cairo cr)))
+ (set! pathlist ())
+ #f)
+
+ (define (circle score x0 y0 rad . rest)
+ (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
+ (draw-dot (->x x0) (->y y0)
+ (floor (* ps-size rad 2))
+ ps-snd ps-chn ps-ax cr)
+ (free-cairo cr)))
+
+ (define (fill-rectangle-1 . args)
+ (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn))))
+ (new-args (copy args (make-list 9 #f))))
+ (if (not (new-args 6))
+ (set! (new-args 6) time-graph))
+ (set! (new-args 8) cr)
+ (apply fill-rectangle new-args)
+ (free-cairo cr))))
+ (begin
+ (define* (fill-in score :rest args)
+ (if (not (null? pathlist))
+ (fill-polygon
+ (make-polygon
+ (reverse pathlist))
+ ps-snd ps-chn ps-ax))
+ (set! pathlist ())
+ #f)
+
+ (define (draw score arg)
+ (if (not (null? pathlist))
+ (draw-lines
+ (make-polygon
+ (reverse pathlist))
+ ps-snd ps-chn ps-ax))
+ (set! pathlist ())
+ #f)
+
+ (define (circle score x0 y0 rad . rest)
+ (draw-dot (->x x0) (->y y0)
+ (floor (* ps-size rad 2))
+ ps-snd ps-chn ps-ax))
+
+ (define fill-rectangle-1 fill-rectangle)
+ ))
+
+
+;(define-macro (defvar name value) `(define ,name ,value))
+(define defvar define)
+
+;(define-macro (setf a b) `(set! ,a ,b))
+;(define-macro setf set!)
+(define setf set!)
(define-macro (defun name ignored-args . body)
;; in cmn-glyphs every defun has two args, the "score" and an optional "style"
@@ -189,26 +233,24 @@
(define (frequency->pitch freq)
(floor (* 12 (+ (log (/ freq 16.351) 2) (/ 1.0 24)))))
- (define (pitch->note-octave-and-accidental pitch)
- (let* ((pclass (modulo pitch 12))
- (octave (floor (/ pitch 12)))
- (cclass (case pclass
- ((0 1) 0) ; c-sharp
- ((2) 1)
- ((3 4) 2) ; e-flat
- ((5 6) 3) ; f-sharp
- ((7) 4)
- ((8 9) 5) ; a-flat
- (else 6)))) ; b-flat
- (list pclass octave
- (if (memv pclass '(1 6))
- :sharp
- (and (memv pclass '(3 8 10))
- :flat))
- cclass
- pitch)))
-
- (pitch->note-octave-and-accidental (frequency->pitch freq)))
+ (let* ((pitch (frequency->pitch freq))
+ (pclass (modulo pitch 12))
+ (octave (floor (/ pitch 12)))
+ (cclass (case pclass
+ ((0 1) 0) ; c-sharp
+ ((2) 1)
+ ((3 4) 2) ; e-flat
+ ((5 6) 3) ; f-sharp
+ ((7) 4)
+ ((8 9) 5) ; a-flat
+ (else 6)))) ; b-flat
+ (list pclass octave
+ (if (memv pclass '(1 6))
+ :sharp
+ (and (memv pclass '(3 8 10))
+ :flat))
+ cclass
+ pitch)))
(define note-data->pclass car)
(define note-data->octave cadr)
@@ -216,15 +258,21 @@
(define note-data->cclass cadddr)
(define (note-data->pitch val) (list-ref val 4))
-
-(define (draw-staff x0 y0 width line-sep)
- (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
- (do ((line 0 (+ 1 line))
- (x x0)
- (y y0 (+ y line-sep)))
- ((= line 5))
- (draw-line x y (+ x width) y ps-snd ps-chn time-graph cr))
- (free-cairo cr)))
+(if (provided? 'snd-gtk)
+ (define (draw-staff x0 y0 width line-sep)
+ (let ((cr (make-cairo (car (channel-widgets ps-snd ps-chn)))))
+ (do ((line 0 (+ 1 line))
+ (x x0)
+ (y y0 (+ y (floor line-sep))))
+ ((= line 5))
+ (draw-line x y (floor (+ x width)) y ps-snd ps-chn time-graph cr))
+ (free-cairo cr)))
+ (define (draw-staff x0 y0 width line-sep)
+ (do ((line 0 (+ 1 line))
+ (x x0)
+ (y y0 (+ y (floor line-sep))))
+ ((= line 5))
+ (draw-line x y (floor (+ x width)) y))))
(define treble-tag-y 30)
@@ -243,9 +291,10 @@
(if accidental 0.1 0.0)
(if (< dur .8) 0.5 0.0))
size))
- (line (if treble
- (+ (* (- 5 octave) 7) (- 3 cclass))
- (+ (* (- 3 octave) 7) (- 5 cclass))))
+ (line (- (if treble
+ (+ (* (- 5 octave) 7) 3)
+ (+ (* (- 3 octave) 7) 5))
+ cclass))
(notehead-x x0)
(notehead-y y0))
@@ -279,19 +328,28 @@
(if (> line 9)
(do ((i 10 (+ i 2)))
((>= i line))
- (fill-rectangle (- x0 (* .1 size)) (+ y0 (* -.02 size) (* line-sep 0.5 i)) (* .5 size) (* .05 size))))
+ (fill-rectangle-1 (floor (- x0 (* .1 size)))
+ (floor (+ y0 (* -.02 size) (* line-sep 0.5 i)))
+ (floor (* .5 size))
+ (floor (* .05 size)))))
(if (< line 0)
(do ((i -2 (- i 2)))
((< i line))
- (fill-rectangle (- x0 (* .1 size)) (+ y0 (* -.02 size) (* line-sep 0.5 i)) (* .5 size) (* .05 size))))
+ (fill-rectangle-1 (floor (- x0 (* .1 size)))
+ (floor (+ y0 (* -.02 size) (* line-sep 0.5 i)))
+ (floor (* .5 size))
+ (floor (* .05 size)))))
;; stem
(if (< dur 3)
- (fill-rectangle
+ (fill-rectangle-1
(if (> line 3) ; stem up
- (values (+ x0 line-sep) (+ y0 (* 0.02 size) (* size -0.8) (* line-sep 0.5 line)))
- (values (- x0 (* size 0.02)) (+ y0 (* line-sep line 0.5))))
- (* size 0.05) (* size 0.8)))
+ (values (floor (+ x0 line-sep))
+ (floor (+ y0 (* 0.02 size) (* size -0.8) (* line-sep 0.5 line))))
+ (values (floor (- x0 (* size 0.02)))
+ (floor (+ y0 (* line-sep line 0.5)))))
+ (floor (* size 0.05))
+ (floor (* size 0.8))))
;; flags
(if (< dur .6)
@@ -319,8 +377,8 @@
(height *mix-tag-height*)
(home (mix-home id)))
(if (not (= oy -1)) ; already erased?
- (fill-rectangle (- ox 1 (/ width 2)) (- oy 1 height) (+ width 2) (+ height 2) (car home) (cadr home) time-graph #t))
- (fill-rectangle (- x (/ width 2)) (- y height) width height (car home) (cadr home))))
+ (fill-rectangle-1 (- ox 1 (/ width 2)) (- oy 1 height) (+ width 2) (+ height 2) (car home) (cadr home) time-graph #t))
+ (fill-rectangle-1 (- x (/ width 2)) (- y height) width height (car home) (cadr home))))
(hook-push draw-mix-hook
(lambda (hook)
diff --git a/nb.scm b/nb.scm
index 6a531f5..4a37ac1 100644
--- a/nb.scm
+++ b/nb.scm
@@ -64,39 +64,37 @@
(let ((documentation "(files-popup-info type position name) is intended as a mouse-enter-label hook function.
It causes a description of the file to popup when the mouse crosses the filename"))
(lambda (type position name)
- (define file-info
- (lambda (file)
- ;; (file-info file) -> description (as a string) of file
- (format #f "~A: ~% chans: ~D, srate: ~D, len: ~A~% ~A ~A~A~% written: ~A~A~A"
- file
- (channels file)
- (srate file)
- (let ((den (* (channels file) (srate file))))
- (if (> den 0)
- (format #f "~1,3F" (* 1.0 (/ (mus-sound-samples file) den)))
- "unknown"))
- (mus-header-type-name (mus-sound-header-type file))
- (mus-sample-type-name (mus-sound-sample-type file))
- (if (mus-sound-maxamp-exists? file)
- (format #f "~% maxamp: ~A" (mus-sound-maxamp file))
- "")
- (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date file)))
- (let ((comment (mus-sound-comment file)))
- (if (and (string? comment)
- (> (length comment) 0))
- (format #f "~% comment: ~A" comment)
- ""))
- (if (not (and use-gdbm
- (file-exists? nb-database)))
- ""
- (let* ((ptr (gdbm-open nb-database 'read))
- (note (gdbm-fetch ptr file)))
- (gdbm-close! ptr)
- (if (string? note)
- (format #f "~%~A" note)
- ""))))))
-
- (let ((region-viewer 2))
+ (let ((file-info (lambda (file)
+ ;; (file-info file) -> description (as a string) of file
+ (format #f "~A: ~% chans: ~D, srate: ~D, len: ~A~% ~A ~A~A~% written: ~A~A~A"
+ file
+ (channels file)
+ (srate file)
+ (let ((den (* (channels file) (srate file))))
+ (if (> den 0)
+ (format #f "~1,3F" (* 1.0 (/ (mus-sound-samples file) den)))
+ "unknown"))
+ (mus-header-type-name (mus-sound-header-type file))
+ (mus-sample-type-name (mus-sound-sample-type file))
+ (if (mus-sound-maxamp-exists? file)
+ (format #f "~% maxamp: ~A" (mus-sound-maxamp file))
+ "")
+ (strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date file)))
+ (let ((comment (mus-sound-comment file)))
+ (if (and (string? comment)
+ (> (length comment) 0))
+ (format #f "~% comment: ~A" comment)
+ ""))
+ (if (not (and use-gdbm
+ (file-exists? nb-database)))
+ ""
+ (let* ((ptr (gdbm-open nb-database 'read))
+ (note (gdbm-fetch ptr file)))
+ (gdbm-close! ptr)
+ (if (string? note)
+ (format #f "~%~A" note)
+ ""))))))
+ (region-viewer 2))
(set! nb-mouse-response-time (get-internal-real-time))
(if (not (= type region-viewer))
(let ((info-exists (list-ref (dialog-widgets) 15)))
diff --git a/new-backgrounds.scm b/new-backgrounds.scm
index 99a177b..c760f50 100644
--- a/new-backgrounds.scm
+++ b/new-backgrounds.scm
@@ -901,75 +901,15 @@
"..aa#a#aaab.aa..#.a.#a#a.....#aaa#aaa.a.a.aaaa.a...ab....a.aa.aa.aaaaaaa.a.aaa#aaaaaaaa...aa.a.a..a..aaa.aa#.....a....a.aab.aaaa"
))
-(define blueish (list
+(define blueish (append
+ (list
"64 64 2 1"
" c None"
-". c #0D5483"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-"................................................................"
-))
+". c #0D5483")
+ (do ((i 0 (+ i 1))
+ (lst ()))
+ ((= i 64) lst)
+ (set! lst (cons (make-string 64 #\.) lst)))))
(define smoke (list
"244 244 63 1"
diff --git a/new-effects.scm b/new-effects.scm
index a48c375..3b433c0 100644
--- a/new-effects.scm
+++ b/new-effects.scm
@@ -75,7 +75,7 @@
(map-channel (func (- end beg)) beg (+ end overlap 1) snd chn
#f
(format #f "~A ~A ~A" (origin target (- end beg)) (if (eq? target 'sound) 0 beg)
- (and (not (eq? target 'sound)) (+ 1 (- end beg))))))))
+ (and (not (eq? target 'sound)) (- (+ end 1) beg)))))))
(if (> snc 0)
(all-chans)
(list (list (selected-sound)) (list (selected-channel))))))))))
@@ -84,10 +84,8 @@
(let ((pix #f))
(lambda ()
(if (not pix)
- (let* ((shell (cadr (main-widgets)))
- (dpy (XtDisplay shell))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr))
+ (let* ((dpy (XtDisplay (cadr (main-widgets))))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy)))
(col (XColor)))
(if (= (XAllocNamedColor dpy cmap "yellow" col col) 0)
(snd-error "can't allocate yellow!")
@@ -124,9 +122,9 @@
XmNarmCallback (list (lambda (w c i)
(target-callback type))
#f))))
- (list "entire sound" "selection" "between marks")
- (list 'sound 'selection 'marks)
- (list #t #f #f))
+ '("entire sound" "selection" "between marks")
+ '(sound selection marks)
+ '(#t #f #f))
(if truncate-callback
(XtCreateManagedWidget "trsep" xmSeparatorWidgetClass mainform
(list XmNorientation XmHORIZONTAL))
@@ -193,8 +191,7 @@
(define (scale-envelope e scl)
(if (null? e)
()
- (append (list (car e) (* scl (cadr e)))
- (scale-envelope (cddr e) scl))))
+ (cons (car e) (cons (* scl (cadr e)) (scale-envelope (cddr e) scl)))))
(lambda ()
(if (Widget? gain-dialog)
@@ -208,7 +205,7 @@
gain-label
(lambda (w context info)
- (let ((with-env (and (not (equal? (xe-envelope gain-envelope) (list 0.0 1.0 1.0 1.0)))
+ (let ((with-env (and (not (equal? (xe-envelope gain-envelope) '(0.0 1.0 1.0 1.0)))
(scale-envelope (xe-envelope gain-envelope) gain-amount))))
(if (eq? gain-target 'sound)
(if with-env
@@ -579,21 +576,19 @@
(flecho-target 'sound)
(flecho-truncate #t))
(lambda ()
- (define flecho-1
- (lambda (scaler secs cutoff)
- (let ((flt (make-fir-filter :order 4 :xcoeffs (float-vector .125 .25 .25 .125)))
- (del (make-delay (round (* secs (srate)))))
- (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
- (lambda (inval)
- (+ inval
- (delay del
- (fir-filter flt (* scaler (+ (tap del) (* (env genv) inval))))))))))
-
(unless (Widget? flecho-dialog)
;; if flecho-dialog doesn't exist, create it
(let ((initial-flecho-scaler 0.5)
(initial-flecho-delay 0.9)
- (sliders ()))
+ (sliders ())
+ (flecho-1 (lambda (scaler secs cutoff)
+ (let ((flt (make-fir-filter :order 4 :xcoeffs (float-vector .125 .25 .25 .125)))
+ (del (make-delay (round (* secs (srate)))))
+ (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
+ (lambda (inval)
+ (+ inval
+ (delay del
+ (fir-filter flt (* scaler (+ (tap del) (* (env genv) inval)))))))))))
(set! flecho-dialog
(make-effect-dialog
flecho-label
@@ -667,25 +662,23 @@
(zecho-target 'sound)
(zecho-truncate #t))
(lambda ()
- (define zecho-1
- (lambda (scaler secs frq amp cutoff)
- (let* ((os (make-oscil frq))
- (len (round (* secs (srate))))
- (del (make-delay len :max-size (round (+ len amp 1))))
- (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
- (lambda (inval)
- (+ inval
- (delay del
- (* scaler (+ (tap del) (* (env genv) inval)))
- (* amp (oscil os))))))))
-
(unless (Widget? zecho-dialog)
;; if zecho-dialog doesn't exist, create it
(let ((initial-zecho-scaler 0.5)
(initial-zecho-delay 0.75)
(initial-zecho-freq 6)
(initial-zecho-amp 10.0)
- (sliders ()))
+ (sliders ())
+ (zecho-1 (lambda (scaler secs frq amp cutoff)
+ (let* ((os (make-oscil frq))
+ (len (round (* secs (srate))))
+ (del (make-delay len :max-size (round (+ len amp 1))))
+ (genv (make-env (list 0.0 1.0 cutoff 1.0 (+ cutoff 1) 0.0 (+ cutoff 100) 0.0) :length (+ cutoff 100))))
+ (lambda (inval)
+ (+ inval
+ (delay del
+ (* scaler (+ (tap del) (* (env genv) inval)))
+ (* amp (oscil os)))))))))
(set! zecho-dialog
(make-effect-dialog
zecho-label
@@ -764,7 +757,7 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(define effects-comb-filter
(let ((documentation "(effects-comb-filter scaler-1 size beg dur snd chn) is used by the effects dialog to tie into edit-list->function"))
(lambda* (scaler size beg dur snd chn)
- (let ((delay-line (make-float-vector size 0.0))
+ (let ((delay-line (make-float-vector size))
(delay-loc 0))
(lambda (x)
(let ((result (delay-line delay-loc)))
@@ -1191,15 +1184,6 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(new-comb-chord-dialog #f)
(new-comb-chord-target 'sound))
(lambda ()
- (define new-comb-chord
- (lambda (scaler size amp interval-one interval-two)
- ;; Comb chord filter: create chords by using filters at harmonically related sizes.
- (let ((cs (make-comb-bank (vector (make-comb scaler size)
- (make-comb scaler (* size interval-one))
- (make-comb scaler (* size interval-two))))))
- (lambda (x)
- (* amp (comb-bank cs x))))))
-
(unless (Widget? new-comb-chord-dialog)
;; if new-comb-chord-dialog doesn't exist, create it
(let ((initial-new-comb-chord-scaler 0.95)
@@ -1207,7 +1191,14 @@ the delay time in seconds, the modulation frequency, and the echo amplitude."))
(initial-new-comb-chord-amp 0.3)
(initial-new-comb-chord-interval-one 0.75)
(initial-new-comb-chord-interval-two 1.20)
- (sliders ()))
+ (sliders ())
+ (new-comb-chord (lambda (scaler size amp interval-one interval-two)
+ ;; Comb chord filter: create chords by using filters at harmonically related sizes.
+ (let ((cs (make-comb-bank (vector (make-comb scaler size)
+ (make-comb scaler (floor (* size interval-one)))
+ (make-comb scaler (floor (* size interval-two)))))))
+ (lambda (x)
+ (* amp (comb-bank cs x)))))))
(set! new-comb-chord-dialog
(make-effect-dialog
new-comb-chord-label
@@ -1557,8 +1548,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(define (scale-envelope e scl)
(if (null? e)
()
- (append (list (car e) (* scl (cadr e)))
- (scale-envelope (cddr e) scl))))
+ (cons (car e) (cons (* scl (cadr e)) (scale-envelope (cddr e) scl)))))
(if (Widget? src-timevar-dialog)
(activate-dialog src-timevar-dialog)
@@ -1582,8 +1572,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(let ((pts (plausible-mark-samples)))
(if pts
(let* ((beg (car pts))
- (end (cadr pts))
- (len (- end beg)))
+ (len (- (cadr pts) beg)))
(src-channel (make-env env :length len) beg len (selected-sound)))))))))
(lambda (w context info)
@@ -1692,7 +1681,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(define am-effect
(lambda (freq)
(let* ((os (make-oscil freq))
- (need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (need-env (not (equal? (xe-envelope am-effect-envelope) '(0.0 1.0 1.0 1.0))))
(e (and need-env (make-env (xe-envelope am-effect-envelope) :length (effect-framples am-effect-target)))))
(if need-env
(lambda (inval)
@@ -1717,7 +1706,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
am-effect-target
(lambda (target samps)
(format #f "effects-am ~A ~A" am-effect-amount
- (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) (list 0.0 1.0 1.0 1.0))))
+ (let* ((need-env (not (equal? (xe-envelope am-effect-envelope) '(0.0 1.0 1.0 1.0))))
(e (and need-env (xe-envelope am-effect-envelope))))
(and e (format #f "'~A" e)))))
#f))
@@ -1787,7 +1776,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
(define rm-effect ; avoid collision with examp.scm
(lambda (freq gliss-env)
(let* ((os (make-oscil freq))
- (need-env (and rm-envelope (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0)))))
+ (need-env (and rm-envelope (not (equal? (xe-envelope rm-envelope) '(0.0 1.0 1.0 1.0)))))
(e (and need-env (make-env (xe-envelope rm-envelope) :length (effect-framples rm-target)))))
(if need-env
(lambda (inval)
@@ -1813,7 +1802,7 @@ Values greater than 1.0 speed up file play, negative values reverse it."))
rm-target
(lambda (target samps)
(format #f "effects-rm ~A ~A" rm-frequency
- (let* ((need-env (not (equal? (xe-envelope rm-envelope) (list 0.0 1.0 1.0 1.0))))
+ (let* ((need-env (not (equal? (xe-envelope rm-envelope) '(0.0 1.0 1.0 1.0))))
(e (and need-env (xe-envelope rm-envelope))))
(and e (format #f "'~A" e)))))
#f))
@@ -2309,7 +2298,7 @@ Adds reverberation scaled by reverb amount, lowpass filtering, and feedback. Mov
(lambda (w context info)
(let ((e (xe-envelope place-sound-envelope)))
- (place-sound mono-snd stereo-snd (if (not (equal? e (list 0.0 1.0 1.0 1.0))) e pan-pos))))
+ (place-sound mono-snd stereo-snd (if (not (equal? e '(0.0 1.0 1.0 1.0))) e pan-pos))))
(lambda (w context info)
(help-dialog "Place sound"
@@ -2582,7 +2571,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
XmNbottomAttachment XmATTACH_FORM
XmNlabelString s1
XmNbackground *basic-color*)))
- (fft-labels (map XmStringCreateLocalized (list "64" "128" "256" "512" "1024" "4096")))
+ (fft-labels (map XmStringCreateLocalized '("64" "128" "256" "512" "1024" "4096")))
(combo (XtCreateManagedWidget "fftsize" xmComboBoxWidgetClass frm
(list XmNleftAttachment XmATTACH_WIDGET
XmNleftWidget lab
@@ -2644,7 +2633,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
XmNset (= size cross-synth-fft-size)))))
(if (= size cross-synth-fft-size)
(set! cross-synth-default-fft-widget button))))
- (list 64 128 256 512 1024 4096))
+ '(64 128 256 512 1024 4096))
(XmStringFree s1)))
(add-target (XtParent (car sliders))
@@ -3044,7 +3033,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
(> (abs (- samp1 samp2)) local-max)
(< (abs (- samp0 samp2)) (/ local-max 2)))
(return (- ctr 1))))))))))
- (when click
+ (when (integer? click)
(smooth-sound (- click 2) 4)
(remove-click (+ click 2)))))))
@@ -3057,7 +3046,7 @@ the synthesis amplitude, the FFT size, and the radius value."))
(do ((i 0 (+ i 1)))
((= i len))
(let ((inval (next-sample reader)))
- (set! lasty (+ inval (- (* 0.999 lasty) lastx)))
+ (set! lasty (- (+ inval (* 0.999 lasty)) lastx))
(set! lastx inval)
(float-vector-set! data i lasty))))
(float-vector->channel data 0 len snd chn current-edit-position "effects-remove-dc")))
diff --git a/nrev.scm b/nrev.scm
index 57b589d..0ada44e 100644
--- a/nrev.scm
+++ b/nrev.scm
@@ -13,9 +13,9 @@
;; output-scale can be used to boost the reverb output
(let ((dly-len (if (= (floor *clm-srate*) 44100)
- (vector 2467 2753 3217 3533 3877 4127 599 197 67 101 97 73 67 53 37)
+ #(2467 2753 3217 3533 3877 4127 599 197 67 101 97 73 67 53 37)
(and (= (floor *clm-srate*) 22050)
- (vector 1237 1381 1607 1777 1949 2063 307 97 31 53 47 37 31 29 17))))
+ #(1237 1381 1607 1777 1949 2063 307 97 31 53 47 37 31 29 17))))
(chan2 (> (channels *output*) 1))
(chan4 (= (channels *output*) 4)))
@@ -31,7 +31,7 @@
val
(next-prime (+ val 2))))
- (set! dly-len (vector 1433 1601 1867 2053 2251 2399 347 113 37 59 53 43 37 29 19))
+ (set! dly-len #(1433 1601 1867 2053 2251 2399 347 113 37 59 53 43 37 29 19))
(do ((i 0 (+ i 1)))
((= i 15))
(let ((val (floor (* srscale (dly-len i)))))
diff --git a/numerics.scm b/numerics.scm
index f0aaa71..7560354 100644
--- a/numerics.scm
+++ b/numerics.scm
@@ -76,8 +76,7 @@
;;; from Numerical Recipes
(define (plgndr L m x) ;Legendre polynomial P m/L (x), m and L integer
;0 <= m <= L and -1<= x <= 1 (x real)
- (if (or (< m 0)
- (> m L)
+ (if (or (not (<= 0 m L))
(> (abs x) 1.0))
(snd-error "invalid arguments to plgndr")
(let ((pmm 1.0)
@@ -706,58 +705,55 @@
(define (series m id)
;; This routine evaluates the series sum_k 16^(id-k)/(8*k+m) using the modular exponentiation technique.
- (define expm
- (let* ((ntp 25)
- (tp1 0)
- (tp (make-vector ntp)))
- (lambda (p ak)
- ;; expm = 16^p mod ak. This routine uses the left-to-right binary exponentiation scheme.
-
- ;; If this is the first call to expm, fill the power of two table tp.
- (if (= tp1 0)
- (begin
- (set! tp1 1)
- (set! (tp 0) 1.0)
- (do ((i 1 (+ i 1)))
- ((= i ntp))
- (set! (tp i) (* 2.0 (tp (- i 1)))))))
-
- (if (= ak 1.0)
- 0.0
- (let ((pl -1))
- ;; Find the greatest power of two less than or equal to p.
- (do ((i 0 (+ i 1)))
- ((or (not (= pl -1))
- (= i ntp)))
- (if (> (tp i) p)
- (set! pl i)))
-
- (if (= pl -1) (set! pl ntp))
- (let ((pt (tp (- pl 1)))
- (p1 p)
- (r 1.0))
- ;; Perform binary exponentiation algorithm modulo ak.
-
- (do ((j 1 (+ j 1)))
- ((> j pl) r)
- (if (>= p1 pt)
+ (let ((expm (let* ((ntp 25)
+ (tp1 0)
+ (tp (make-vector ntp)))
+ (lambda (p ak)
+ ;; expm = 16^p mod ak. This routine uses the left-to-right binary exponentiation scheme.
+
+ ;; If this is the first call to expm, fill the power of two table tp.
+ (if (= tp1 0)
(begin
- (set! r (* 16.0 r))
- (set! r (- r (* ak (floor (/ r ak)))))
- (set! p1 (- p1 pt))))
- (set! pt (* 0.5 pt))
- (if (>= pt 1.0)
- (begin
- (set! r (* r r))
- (set! r (- r (* ak (floor (/ r ak))))))))))))))
-
- (let ((eps 1e-17)
+ (set! tp1 1)
+ (set! (tp 0) 1.0)
+ (do ((i 1 (+ i 1)))
+ ((= i ntp))
+ (set! (tp i) (* 2.0 (tp (- i 1)))))))
+
+ (if (= ak 1.0)
+ 0.0
+ (let ((pl -1))
+ ;; Find the greatest power of two less than or equal to p.
+ (do ((i 0 (+ i 1)))
+ ((or (not (= pl -1))
+ (= i ntp)))
+ (if (> (tp i) p)
+ (set! pl i)))
+
+ (if (= pl -1) (set! pl ntp))
+ (let ((pt (tp (- pl 1)))
+ (p1 p)
+ (r 1.0))
+ ;; Perform binary exponentiation algorithm modulo ak.
+
+ (do ((j 1 (+ j 1)))
+ ((> j pl) r)
+ (if (>= p1 pt)
+ (begin
+ (set! r (* 16.0 r))
+ (set! r (- r (* ak (floor (/ r ak)))))
+ (set! p1 (- p1 pt))))
+ (set! pt (* 0.5 pt))
+ (if (>= pt 1.0)
+ (begin
+ (set! r (* r r))
+ (set! r (- r (* ak (floor (/ r ak))))))))))))))
+ (eps 1e-17)
(s 0.0))
(do ((k 0 (+ k 1)))
((= k id))
(let* ((ak (+ (* 8 k) m))
- (p (- id k))
- (t (expm p ak)))
+ (t (expm (- id k) ak)))
(set! s (+ s (/ t ak)))
(set! s (- s (floor s)))))
@@ -765,8 +761,7 @@
(let ((happy #f))
(do ((k id (+ k 1)))
((or (> k (+ id 100)) happy) s)
- (let* ((ak (+ (* 8 k) m))
- (t (/ (expt 16.0 (- id k)) ak)))
+ (let ((t (/ (expt 16.0 (- id k)) (+ (* 8 k) m))))
(set! happy (< t eps))
(set! s (+ s t))
(set! s (- s (floor s))))))))
@@ -778,7 +773,7 @@
(s3 (series 5 id))
(s4 (series 6 id))
(pid (- (+ (* 4.0 s1) (* -2.0 s2)) s3 s4)))
- (set! pid (+ 1.0 (- pid (floor pid))))
+ (set! pid (- (+ 1.0 pid) (floor pid)))
(ihex pid 10 chx)
(format #t " position = ~D~% fraction = ~,15F~% hex digits = ~S~%" id pid chx)))
diff --git a/peak-phases.scm b/peak-phases.scm
index cf6b260..10a52a2 100644
--- a/peak-phases.scm
+++ b/peak-phases.scm
@@ -120,7 +120,6 @@
;;; 6 all -------------------------------------------------------------------------------- ; 2.4494
(vector 6 2.8200183503167 (fv 0 0 0 0 1 0)
- 2.5598928928375 (fv 0.0 0.91140931844711 0.34124284982681 1.3568490743637 1.4451304674149 1.2563138008118)
2.5509102344513 (fv 0.0 0.88722838124921 0.26020415169852 1.2966409163042 1.3233535939997 1.15281977798)
2.5493413065822 (fv 0.0 0.88655948906463 0.26426014425456 1.3003055923199 1.3306838066896 1.1573162129407)
@@ -129,6 +128,15 @@
2.549386 (fv 0.000000 0.113427 1.735535 1.699526 0.668940 1.842412)
2.549385 (fv 0.000000 1.886568 0.264458 0.300485 1.331039 0.157570)
2.549360 (fv 0.000000 0.886491 0.264319 1.300337 1.330828 1.157371)
+
+ 2.549302 #(0.000000 0.886538 0.264356 1.300390 1.330858 1.157418)
+
+ ;; random runs:
+ 2.549303 #(0.000000 -0.113461 0.264357 0.300392 -0.669139 0.157420)
+ 2.549303 #(0.000000 0.113461 -0.264357 -0.300391 0.669139 -0.157420)
+ ;; 2.549304 #(0.000000 0.113458 -0.264363 1.699605 0.669131 1.842572)
+ 2.549303 #(0.000000 0.113461 1.735641 -0.300392 0.669137 -0.157422)
+ 2.549303 #(0.000000 0.886537 0.264354 1.300389 1.330856 1.157416)
)
;;; 7 all -------------------------------------------------------------------------------- ; 2.64575
@@ -222,8 +230,18 @@
3.524879 (fv 0.000000 0.948502 1.829668 0.364984 1.544240 0.488687 0.147763 0.945396 1.000061 1.903153 -0.004551 1.840699 1.384079)
3.524127 (fv 0.000000 0.948325 1.829839 0.364837 1.544231 0.489035 0.147691 0.944940 1.000036 1.902764 -0.004752 1.840449 1.384160)
+ ;; others:
+ 3.52549096213107 #(0.0 1.948154 1.82948 1.364841 1.544093 1.488616 0.147127 1.944553 0.999452 0.902129 1.99412 0.839328 1.383104)
+ 3.52549096875855 #(0.0 0.948154 1.82948 0.364841 1.544093 0.488616 0.147127 0.944553 0.999452 1.902129 1.99412 1.839328 1.383104)
+ 3.52549096484103 #(0.0 0.051846 0.17052 0.63516 0.455907 0.511384 -0.147127 0.055447 1.000548 1.097871 0.00588 1.160672 0.616896)
+
;; pp:
3.850623 (fv 0.000000 0.969515 0.236902 1.700081 1.532485 1.012414 0.716276 0.879825 0.831162 1.111747 1.357361 -0.014630 0.962342)
+
+ ;; random runs:
+ 3.548466 #(0.000000 0.145104 0.529448 0.690774 0.918949 0.803743 0.300955 0.527094 1.381692 -0.078636 0.898029 0.095477 1.535845)
+ 3.551952 #(0.000000 0.200284 0.556001 0.721731 0.948469 0.867294 0.332298 0.608081 1.523631 -0.027439 1.029613 0.233328 1.650494)
+ 3.565324 #(0.000000 1.479692 0.716290 0.470867 1.057103 -0.084215 -0.738273 -0.085308 0.431895 0.677280 0.250455 0.062101 0.461117)
)
;;; 14 all -------------------------------------------------------------------------------- ; 3.7416
@@ -235,6 +253,16 @@
;; pp:
3.738333 (fv 0.000000 0.876144 1.749283 0.255257 1.233908 0.925717 1.713300 0.790918 0.423428 0.079568 -0.060539 0.064404 0.601933 0.291808)
+
+ ;; others:
+ 3.612481978033266 #(0.0 0.971346 1.469893 0.504214 0.476137 1.581023 1.896271 1.513152 0.566905 1.159563 1.260271 1.05942 1.748907 1.296875)
+ 3.612481989948184 #(0.0 1.971346 1.469893 1.504214 0.476137 0.581023 1.896271 0.513152 0.566905 0.159563 1.260271 0.05942 1.748907 0.296875)
+ 3.612481914145143 #(0.0 1.028654 0.530107 1.495786 -0.476137 0.418977 0.103729 0.486848 1.433095 0.840437 0.739729 0.94058 0.251093 0.703125)
+
+ ;; random runs:
+ 3.650982 #(0.000000 0.112109 0.601952 0.789556 0.321827 0.641689 1.325218 0.620188 0.862204 0.131948 1.628685 0.381668 1.695079 1.331292)
+ 3.672439 #(0.000000 1.298581 0.470888 1.081624 -0.056336 1.648423 0.916941 0.524303 1.082817 1.859457 0.055963 1.803632 1.767059 0.115666)
+ 3.727206 #(0.000000 1.840981 0.831398 1.214172 0.497021 1.582168 0.468315 0.998613 1.548880 1.565691 1.193536 -0.412758 1.463929 0.679465)
)
;;; 15 all -------------------------------------------------------------------------------- ; 3.8729
@@ -283,16 +311,24 @@
;; pp:
4.321309 (fv 0.000000 0.745098 1.155175 -0.037958 0.532342 1.473567 0.665377 -0.049708 1.767937 0.914818 -0.119772 -0.388406 1.775638 1.206519 1.079401 1.118695 1.930701 1.737887 -0.008406)
+
+ ;; 20 - 1
+ 4.368453 #(0.000000 1.547665 1.565484 -0.064501 -0.355088 0.488366 0.392690 -0.094784 0.724088 1.208934 0.016380 0.236409 -0.498288 1.627216 1.538939 0.284041 1.423487 0.812330 1.368338)
)
;;; 20 all -------------------------------------------------------------------------------- ; 4.4721
(vector 20 5.202707605727 (fv 0 0 0 0 1 1 0 1 0 0 1 0 1 1 1 0 1 1 1 0)
4.288981 (fv 0.000000 1.288096 1.467454 -0.169090 1.858403 0.280935 0.217741 -0.031571 0.876318 1.220549 0.027164 0.381448 1.736192 1.508757 1.292734 0.007137 1.225400 0.645757 1.237414 0.420948)
- 4.287997 #(0.000000 1.306723 1.491084 -0.138208 -0.106223 0.318045 0.270418 0.024135 0.938829 1.289927 0.097314 0.462063 -0.166575 1.604629 1.393707 0.120917 1.335729 0.768117 1.366096 0.562618)
+ 4.288007 #(0.000000 1.310045 1.497604 -0.134812 -0.097725 0.328441 0.281976 0.032570 0.953720 1.303826 0.111501 0.480774 -0.149523 1.625674 1.415263 0.146621 1.360870 0.796858 1.390400 0.590613)
+ 4.287958 #(0.000000 1.307843 1.492560 -0.136998 -0.104073 0.320652 0.273544 0.026577 0.942663 1.293828 0.101160 0.467007 -0.161748 1.610386 1.399614 0.127790 1.342419 0.775594 1.372823 0.570440)
;; pp:
4.467948 (fv 0.000000 0.926509 1.348679 0.244038 1.242002 0.019828 1.173056 0.068338 1.504010 1.041584 0.276603 1.806452 1.767012 1.665479 1.374797 1.361818 1.827476 0.132481 0.796064 0.727142)
+
+ ;; random runs:
+ 4.373082 #(0.000000 1.736543 0.590014 1.257228 0.334821 0.741756 0.000141 0.933820 1.343880 -0.194453 0.086640 0.579672 0.170191 -0.135507 0.196326 1.615939 0.150737 -0.099336 1.018007 0.681284)
+ 4.391790 #(0.000000 0.479270 0.750624 0.806661 0.057204 -0.463791 0.651494 0.232581 0.978315 0.716505 0.027486 0.118399 -0.244751 -0.223933 0.200251 0.798723 -0.077942 -1.206866 -0.599515 -1.192337)
)
;;; 21 all -------------------------------------------------------------------------------- ; 4.5825
@@ -962,6 +998,10 @@
(vector 80 11.30185508728 (fv 0 1 1 1 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 0 0 1 1 1 1 1 0 1 0 0 0 1 1 0 0 1 1 0 1 1 1 0 0 0 0 1 0 1 0 1 0 1 1 0 0 1 1 1 0 1 0 1 1 1 1 1 1 1 1 0 1 0 1 0 0 1 0 0 1 0)
8.831605 (fv 0.000000 0.718457 0.752874 0.707265 1.105140 1.556866 1.675971 1.743288 1.737050 1.402684 0.726424 0.001544 0.787560 0.610707 0.221912 0.548490 1.255462 0.532840 1.735795 1.159475 0.139393 0.566082 0.477708 1.186070 0.213588 1.697938 1.877210 -0.027617 0.446036 -0.097653 1.420626 0.288659 1.413894 1.358919 0.713009 -0.285435 0.875204 0.375292 0.708148 0.907015 0.596415 1.676708 -0.002236 0.617188 -0.254880 0.679354 1.396570 0.024604 0.491384 1.191175 0.583286 0.255907 0.583959 0.646881 1.743044 0.166682 0.513542 1.079013 0.694687 0.379588 0.528146 0.707196 1.408903 1.510794 1.151055 0.672700 0.297721 -0.154036 1.059849 1.480109 0.687072 0.133333 1.264870 -0.326181 0.342810 1.875130 1.918140 1.634313 0.782341 -0.170226)
+
+ ;; 81 - 1
+ 8.853012 #(0.000000 0.713664 0.751521 0.448581 1.078712 1.434332 -0.106130 1.560883 1.450760 1.498278 0.937332 -0.045737 0.468326 0.366103 0.320014 0.581407 1.184615 0.699951 1.696540 1.157496 0.135085 0.626551 0.420080 1.134483 0.350026 1.714983 1.594968 0.442820 0.488286 -0.156674 1.134813 0.168151 1.216425 0.905956 0.520243 -0.142318 0.437369 0.180759 0.624230 0.569840 0.172595 1.321073 -0.234574 0.786368 -0.490064 0.447127 1.640821 -0.178464 0.308828 0.997718 0.822718 -0.196077 0.281017 0.757467 1.401582 0.240219 0.552190 0.865559 0.311162 0.036903 0.553601 0.299180 1.009477 1.109391 0.804156 0.557491 0.291292 -0.278325 0.995535 -0.048564 0.514170 -0.227699 1.019707 -0.548622 -0.162405 1.658786 1.315882 1.435095 0.750976 -0.261917)
+ ;; stopped due to heat wave
)
;;; 81 all -------------------------------------------------------------------------------- ; 9
@@ -976,8 +1016,8 @@
8.968686 #(0.000000 0.248430 0.863441 0.293416 0.756185 1.379289 -0.270431 1.263800 1.341315 1.557550 1.197384 0.213673 0.196685 0.062803 0.468673 0.734019 1.159371 0.832869 1.483006 0.904988 -0.128901 0.681963 0.619993 1.568168 0.324132 1.473951 1.629584 0.505398 0.500570 -0.070053 1.349935 -0.001861 1.159249 0.864343 0.801291 -0.786597 0.513558 0.362321 0.664120 0.282478 0.118044 1.145415 -0.296862 0.587955 -0.589352 0.600173 1.355457 -0.471847 0.396241 0.750727 1.123705 -0.583153 0.192765 0.272763 0.931980 0.776263 0.394773 0.897959 0.871419 0.420019 0.376219 -0.208891 0.894969 0.785338 0.828230 0.967371 0.361582 -0.266678 0.703981 -0.550373 0.421334 -0.253234 1.003690 -0.389957 -0.015548 -0.430183 -0.152241 1.200914 0.591632 -0.142675 -0.492441)
;; 80+1
- 8.836929 #(0.000000 0.600435 0.759195 0.460866 0.876786 1.482477 0.022359 1.530133 1.386064 1.556967 0.976396 0.025139 0.378942 0.486623 0.305352 0.510982 1.177583 0.608411 1.729528 1.236330 0.190738 0.641421 0.479741 1.167104 0.251154 1.751805 1.529684 0.421282 0.583147 -0.254542 1.145882 0.076055 1.307550 0.788062 0.476419 -0.171713 0.409127 0.068193 0.662941 0.634739 0.179937 1.124114 -0.219237 0.782837 -0.420680 0.508914 1.655542 -0.207171 0.385791 0.948310 0.881939 -0.206557 0.102690 0.659804 1.271695 0.207066 0.533428 0.862800 0.316247 0.044228 0.537516 0.119275 0.869325 1.102893 0.890935 0.541211 0.248483 -0.283730 0.928308 0.005152 0.569189 -0.249080 1.036720 -0.500679 -0.213149 1.594222 1.282267 1.317859 0.748067 -0.281326 -0.552875)
- 8.820685 #(0.000000 0.593630 0.758230 0.465683 0.876524 1.481189 0.021360 1.524018 1.384660 1.558040 0.979102 0.025450 0.375612 0.490752 0.307436 0.514843 1.178678 0.610527 1.730121 1.227185 0.190461 0.641406 0.480351 1.164691 0.252412 1.750200 1.527118 0.419865 0.574258 -0.253171 1.144507 0.077228 1.307466 0.786104 0.467165 -0.173541 0.404628 0.061764 0.661230 0.631406 0.172778 1.124031 -0.219100 0.782068 -0.416493 0.503292 1.655559 -0.202729 0.385799 0.951281 0.886755 -0.209660 0.100539 0.655964 1.272005 0.200569 0.540622 0.867801 0.319978 0.043401 0.528483 0.117444 0.872904 1.107140 0.890387 0.545268 0.258207 -0.290140 0.927740 0.000544 0.566356 -0.246542 1.030323 -0.508880 -0.210882 1.592254 1.281549 1.315862 0.753109 -0.282396 -0.551603)
+ 8.798551 #(0.000000 0.591095 0.766372 0.489633 0.892830 1.470880 0.024266 1.553545 1.397381 1.549957 0.961480 0.030745 0.350509 0.480664 0.324535 0.532859 1.178437 0.600433 1.721653 1.190766 0.203234 0.634172 0.473637 1.167212 0.251931 1.758060 1.536282 0.415486 0.566371 -0.279352 1.143985 0.080086 1.312189 0.802180 0.476214 -0.170351 0.392370 0.054114 0.648162 0.604589 0.159911 1.129280 -0.198924 0.772307 -0.404913 0.496844 1.664189 -0.222495 0.397365 0.945586 0.907997 -0.249926 0.105251 0.650639 1.266007 0.197774 0.522775 0.879085 0.342046 0.049647 0.501455 0.132186 0.903401 1.133013 0.925314 0.555954 0.264446 -0.269660 0.922009 -0.001103 0.579617 -0.224098 1.014084 -0.530017 -0.206754 1.601599 1.281427 1.317681 0.768845 -0.280697 -0.570842)
+ 8.797329 #(0.000000 0.593378 0.769030 0.482050 0.894789 1.469434 0.017291 1.548640 1.399875 1.547111 0.960600 0.029476 0.347173 0.479328 0.324764 0.535557 1.181648 0.603853 1.724567 1.184427 0.201520 0.621022 0.466053 1.172410 0.257155 1.744523 1.537620 0.413349 0.571480 -0.275441 1.147662 0.078171 1.318337 0.797128 0.465604 -0.167976 0.389127 0.046196 0.644876 0.600407 0.146824 1.140648 -0.196543 0.766952 -0.405128 0.495879 1.671836 -0.221864 0.393766 0.946119 0.917743 -0.256291 0.111525 0.645632 1.265055 0.181069 0.525294 0.880675 0.348447 0.049079 0.495123 0.135981 0.911089 1.141680 0.914015 0.556460 0.266976 -0.250402 0.919302 -0.007489 0.586097 -0.221631 1.012419 -0.545708 -0.213348 1.601484 1.279462 1.306339 0.757689 -0.274675 -0.570934)
)
;;; 82 all -------------------------------------------------------------------------------- ; 9.0554
@@ -989,14 +1029,16 @@
8.942054 (fv 0.000000 0.741190 1.211121 1.767480 0.098390 0.839201 1.102556 -0.209453 0.453250 1.122839 0.064920 0.959867 1.388767 0.263801 1.292900 0.219769 1.265994 0.422114 1.103821 -0.093210 0.755477 0.000245 0.969187 1.607339 1.053959 0.313625 1.046034 0.279348 1.465040 0.751688 0.022843 1.470315 0.592990 1.853486 1.118710 0.593243 1.855200 0.862858 0.945784 0.185739 1.601158 1.076300 0.669622 0.291600 1.841348 1.175765 0.663836 0.601642 0.369909 1.837262 -0.023948 1.335189 1.343186 0.755277 0.855544 0.293163 0.518573 0.368668 0.285100 0.386831 1.688397 0.163703 0.172910 0.313842 -0.159903 -0.137818 0.212922 0.539645 0.627827 0.897666 0.865830 1.159886 1.047275 1.360198 1.762925 0.204264 1.078567 0.797293 1.200018 1.357729 0.204458 0.441846)
;; 81+1
- 8.880112 #(0.000000 0.556277 1.048737 0.613952 0.943721 1.398746 0.037508 1.566628 1.720178 1.471825 1.010904 0.025372 0.431461 0.799911 0.262693 0.572971 1.206602 0.470885 -0.146209 1.018200 0.199475 1.039326 0.590090 1.259119 0.106599 1.618621 1.760723 0.128449 0.965865 -0.693032 0.901930 0.079273 0.877431 1.081960 0.292130 -0.302787 0.661667 0.066792 0.553002 0.733824 0.686894 0.969632 -0.164122 0.666971 -0.478541 0.472820 1.668413 -0.165306 0.521892 0.841207 1.141238 0.005202 0.337850 0.736190 1.034924 0.589782 0.482412 0.213340 0.040924 0.191594 0.782320 0.149989 0.926438 1.170121 1.044384 0.654924 0.181060 -0.001892 1.133516 -0.444317 0.800939 0.008067 1.334041 -0.523482 -0.041892 1.486796 1.257363 1.192524 0.832377 -0.233294 -0.488597 0.403022)
- 8.870389 #(0.000000 0.539105 1.020560 0.615701 0.902145 1.387963 0.032876 1.624264 1.691685 1.494854 0.992079 0.020606 0.409928 0.807917 0.254101 0.573450 1.228237 0.499346 -0.152651 1.036348 0.219489 1.037518 0.560376 1.223274 0.125394 1.633074 1.733231 0.124910 0.927101 -0.716583 0.919669 0.061181 0.923685 1.036030 0.279797 -0.280539 0.637433 0.056302 0.550060 0.698308 0.630813 0.945211 -0.178066 0.682062 -0.467876 0.469626 1.667023 -0.217450 0.514912 0.876848 1.096408 -0.029194 0.320719 0.731463 1.010086 0.603898 0.489255 0.223415 0.057358 0.181859 0.772520 0.085671 0.928553 1.165232 1.078291 0.627360 0.183386 -0.026442 1.094239 -0.460656 0.746429 -0.022000 1.289367 -0.534942 -0.061511 1.508274 1.279393 1.222449 0.824799 -0.271340 -0.437408 0.388773)
+ 8.851350 #(0.000000 0.560616 1.028384 0.602446 0.918314 1.370584 0.032799 1.596301 1.697405 1.496371 0.996676 0.029713 0.420383 0.826586 0.248203 0.575317 1.241662 0.486923 -0.146886 1.026281 0.207970 1.026508 0.554521 1.233144 0.124979 1.629837 1.740416 0.133168 0.934365 -0.707656 0.913598 0.062338 0.910383 1.041029 0.285851 -0.273453 0.668898 0.057418 0.546969 0.703739 0.642923 0.958752 -0.195671 0.682461 -0.471844 0.445399 1.669461 -0.200437 0.550525 0.885547 1.105654 -0.043073 0.307985 0.716590 1.018538 0.595943 0.488507 0.208799 0.077662 0.185943 0.759192 0.106129 0.934593 1.168071 1.038861 0.631960 0.173275 -0.022867 1.092552 -0.449400 0.726450 -0.020524 1.292546 -0.564480 -0.067237 1.491273 1.275468 1.239648 0.821121 -0.291412 -0.449925 0.390998)
+ 8.850182 #(0.000000 0.518773 1.039139 0.586918 0.904434 1.417193 0.042683 1.631265 1.694438 1.514894 1.006690 0.003709 0.408784 0.798813 0.249575 0.591222 1.196003 0.490671 -0.162585 1.056459 0.214130 1.070048 0.595570 1.158267 0.152005 1.596646 1.763293 0.137802 1.031270 -0.729765 0.896998 0.017768 0.865646 1.014949 0.251509 -0.314516 0.635325 0.026002 0.490859 0.633543 0.639061 0.944000 -0.171048 0.686904 -0.554012 0.426662 1.660372 -0.276772 0.454353 0.868574 1.080144 0.004571 0.280163 0.786197 1.030805 0.611760 0.535564 0.235350 0.034299 0.186337 0.685227 0.115463 0.933270 1.148318 1.130052 0.634287 0.165289 -0.005574 1.017789 -0.425130 0.702068 -0.051211 1.238786 -0.554979 -0.075667 1.531212 1.295287 1.210341 0.841758 -0.323173 -0.539445 0.363396)
)
;;; 83 all -------------------------------------------------------------------------------- ; 9.1104
(vector 83 11.429935034332 (fv 0 1 1 0 0 0 0 0 1 0 1 1 1 1 1 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 1 1 0 0 0 0 1 1 0 1 1 0 0 1 1 1 0 0 1 0 0 1 0 1 0 1 1 0 1 0 1 0 1 0 0 0 1 0 0 0 0 1 1 0 0)
8.938600 (fv 0.000000 0.414028 0.125789 1.159865 0.086238 0.817482 0.340516 1.199339 -0.170286 1.744945 1.587696 1.158800 1.281058 0.190384 1.473320 0.235428 1.621261 0.225261 1.644931 -0.137023 1.525995 0.691219 0.557902 1.528647 -0.234276 -0.009740 0.044217 0.592778 0.909815 0.773874 0.836299 0.726340 0.981312 0.618405 0.408288 0.150201 0.908250 0.109103 0.413166 0.847395 0.541585 1.672450 1.474939 0.635397 0.153870 -0.014899 1.455728 0.983819 0.181154 0.726107 0.638924 1.106663 0.611788 0.238433 0.670956 1.522770 1.842401 0.939513 -0.051810 1.267322 0.323759 1.831419 1.004026 -0.159128 0.287041 0.349723 0.402841 0.045990 0.570998 1.374651 1.603295 0.760887 1.460939 -0.002747 0.693326 1.517648 0.987805 0.554027 0.029827 0.036863 0.188640 0.849464 1.347102)
+ 8.936213 #(0.000000 0.408201 0.126040 1.158014 0.083410 0.822392 0.340155 1.194042 -0.172082 1.748578 1.586610 1.161056 1.277534 0.186364 1.476999 0.235823 1.627756 0.227972 1.641505 -0.140011 1.528346 0.692010 0.553694 1.528749 -0.231846 -0.009008 0.040533 0.588403 0.914079 0.778413 0.831073 0.723278 0.978128 0.624349 0.400433 0.146060 0.911725 0.111205 0.414216 0.850529 0.541662 1.663794 1.477328 0.641317 0.149613 -0.013692 1.454096 0.985241 0.185917 0.730787 0.637733 1.097840 0.604584 0.240638 0.678667 1.522252 1.845745 0.944051 -0.047786 1.256053 0.323123 1.836166 1.002122 -0.154558 0.287277 0.348279 0.400131 0.048348 0.573133 1.378950 1.603761 0.771384 1.465373 0.014397 0.693518 1.523180 0.987688 0.553385 0.023434 0.030358 0.189016 0.850384 1.349789)
+ 8.934963 #(0.000000 0.388833 0.119269 1.159396 0.084041 0.831926 0.332635 1.176250 -0.176695 1.764815 1.577336 1.167712 1.277058 0.180565 1.483279 0.244455 1.639842 0.231019 1.628465 -0.143232 1.536821 0.704938 0.552153 1.530466 -0.224513 0.010496 0.034106 0.576377 0.939875 0.785468 0.829993 0.715502 0.968124 0.640032 0.396582 0.150458 0.935168 0.123648 0.408167 0.864017 0.545634 1.640474 1.473610 0.636166 0.133436 -0.003429 1.440429 0.982288 0.212836 0.743361 0.639874 1.101557 0.617385 0.271411 0.703361 1.525115 1.857795 0.954785 -0.022712 1.232732 0.327660 1.853705 1.028391 -0.134471 0.306948 0.357972 0.408006 0.063155 0.593195 1.406229 1.598252 0.790489 1.494874 0.055118 0.707198 1.527620 0.974145 0.561751 0.009624 0.051221 0.195975 0.865753 1.371065)
)
;;; 84 all -------------------------------------------------------------------------------- ; 9.1652
@@ -1014,8 +1056,8 @@
9.178091 #(0.000000 0.092570 -0.328688 0.101879 1.164231 0.484791 0.263025 1.451681 1.371169 0.108316 0.583377 0.421708 0.063889 1.308369 1.554699 0.834440 1.382249 1.018775 0.556330 1.227389 0.358177 0.557221 0.316807 0.026851 0.347091 -0.193100 1.503856 1.682820 0.057602 0.906412 1.391283 1.172258 -0.306686 0.435069 -0.568978 -0.558083 1.240277 0.880388 1.809028 1.648747 0.142044 -0.051135 0.843030 1.589081 1.068210 0.522719 0.218341 1.007282 0.577304 0.998448 0.637448 1.458645 0.805087 0.732402 0.662530 1.436936 1.230072 0.780536 0.678657 1.336068 0.047814 0.297831 1.418569 0.786054 0.797109 1.410904 1.430707 0.466713 0.866817 1.332398 -0.186495 1.178146 -0.048740 1.088830 0.300282 0.620896 -0.201097 0.818687 0.773330 1.535207 1.274976 1.303891 1.667213 0.674931 -0.125079)
;; 86-1
- 9.057437 #(0.000000 0.570249 1.184584 1.763388 0.253739 0.874255 1.649278 -0.092856 0.545746 1.441082 0.012387 0.739864 1.567229 0.641869 1.248428 -0.258864 0.979020 0.106196 1.239561 0.188339 0.720317 1.206705 0.453833 1.256155 0.621647 1.775821 0.919384 0.039412 0.513365 0.132311 1.564752 0.722942 -0.071448 0.948131 0.009774 -0.016202 1.545153 0.487923 1.885615 1.372906 0.427563 1.527257 1.364251 0.890503 0.310553 1.662790 1.384147 1.043036 0.692189 -0.262514 1.340606 1.191753 0.846965 0.759339 0.701652 0.227347 0.525330 -0.260407 1.542211 1.308169 1.173799 1.057289 0.913467 1.783655 0.864914 1.204813 0.682233 0.998463 0.661854 1.098908 1.112695 1.765172 1.335644 1.631977 -0.249510 -0.168729 0.097422 0.642025 1.050451 1.546328 0.006675 0.099459 0.586892 1.021930 1.127145)
- 9.056499 #(0.000000 0.570308 1.184668 1.763370 0.253738 0.874213 1.649266 -0.092904 0.545708 1.441048 0.012251 0.739873 1.567319 0.641927 1.248333 -0.259041 0.979149 0.106269 1.239451 0.188403 0.720423 1.206709 0.453748 1.256279 0.621678 1.775878 0.919381 0.039448 0.513410 0.132072 1.564796 0.722923 -0.071345 0.948116 0.009644 -0.016259 1.545160 0.488035 1.885525 1.372878 0.427535 1.527093 1.364161 0.890433 0.310618 1.662754 1.384111 1.043150 0.692172 -0.262652 1.340519 1.191733 0.846909 0.759400 0.701644 0.227485 0.525106 -0.260481 1.542300 1.308046 1.173799 1.057405 0.913483 1.783592 0.864774 1.204856 0.682218 0.998396 0.661847 1.098951 1.112628 1.765109 1.335517 1.632001 -0.249528 -0.168911 0.097451 0.641933 1.050350 1.546283 0.006653 0.099465 0.586819 1.021860 1.127109)
+ 9.051726 #(0.000000 0.572406 1.179943 1.764356 0.253870 0.884356 1.651423 -0.098959 0.541959 1.442287 0.010669 0.741083 1.566729 0.635556 1.249696 -0.254695 0.981029 0.111846 1.237031 0.192536 0.720833 1.204618 0.449694 1.251669 0.627009 1.783356 0.920605 0.035741 0.509227 0.126246 1.562523 0.722635 -0.062975 0.946054 0.007605 -0.013358 1.547325 0.495733 1.888355 1.370030 0.430619 1.521378 1.364477 0.899348 0.311412 1.655627 1.393415 1.043374 0.693073 -0.261616 1.347717 1.190412 0.844199 0.765353 0.699908 0.229316 0.525856 -0.265344 1.545983 1.312840 1.172844 1.057530 0.916299 1.790793 0.869579 1.211374 0.681340 1.001931 0.654601 1.101973 1.110746 1.767977 1.334109 1.636297 -0.247626 -0.168731 0.099708 0.647019 1.050047 1.539415 0.008050 0.095956 0.583789 1.020757 1.124846)
+ 9.049902 #(0.000000 0.563123 1.178518 1.758860 0.262272 0.883025 1.653154 -0.112442 0.544375 1.449563 0.003632 0.735232 1.565378 0.629399 1.249832 -0.245154 0.975371 0.104021 1.230308 0.204936 0.728896 1.200090 0.453859 1.254730 0.634907 1.785857 0.910526 0.028528 0.512985 0.118173 1.563688 0.727580 -0.060681 0.935698 0.002572 -0.009819 1.543537 0.502740 1.889883 1.378460 0.440088 1.520721 1.385983 0.911951 0.319540 1.661394 1.403090 1.043647 0.698513 -0.258428 1.361759 1.190670 0.827100 0.772203 0.674858 0.223364 0.526333 -0.284078 1.542639 1.309275 1.167224 1.067830 0.912739 1.795861 0.867588 1.204585 0.683869 0.992895 0.650909 1.108031 1.113927 1.766016 1.326795 1.627701 -0.242386 -0.176337 0.105000 0.657052 1.065424 1.542526 0.021830 0.089779 0.582222 1.031000 1.120243)
)
;;; 86 all -------------------------------------------------------------------------------- ; 9.27362
@@ -1024,7 +1066,8 @@
9.206953 (fv 0.000000 -0.339088 0.933342 -0.128298 1.099279 0.084536 0.851599 -0.014992 1.465425 1.307317 0.418122 0.289943 1.668778 0.506500 1.696171 1.171193 0.792416 0.989400 0.972892 1.055909 1.790099 1.474165 1.862965 1.486120 1.916599 0.452792 1.686062 0.595804 0.951171 -0.158372 0.842834 1.045604 0.896962 0.721188 0.145646 1.627929 1.192540 1.524829 0.808536 1.173303 0.835497 0.870602 1.525244 1.506688 0.379810 0.397104 0.800652 0.803279 1.193873 1.751911 0.273257 0.582749 0.328287 1.542626 0.758388 0.690207 1.020504 0.688526 -0.031652 0.949811 0.197494 0.391786 1.605605 0.223632 0.906957 1.312801 1.428402 0.597149 1.497710 -0.659689 1.704635 0.962819 1.427359 1.450510 1.282944 1.167035 0.635413 0.328489 1.735204 0.771081 1.542497 0.207128 0.104268 1.136822 -0.363620 0.034704)
;; 87-1
- 9.154099 #(0.000000 0.546512 1.116802 1.888989 0.250808 0.822374 1.651582 -0.005692 0.626109 1.455571 0.073330 0.769650 1.652439 0.510220 1.146206 -0.051780 0.983214 -0.011253 1.055524 0.058792 0.798885 1.375789 0.494600 1.319397 0.591354 1.783545 0.902610 -0.070574 0.807019 0.110199 1.541898 0.751946 0.067110 0.972246 0.094850 1.874652 1.395502 0.413454 1.892267 1.394755 0.404089 1.604275 1.353279 0.912134 0.279923 1.677474 1.359302 1.024954 0.494212 -0.204624 1.444381 1.142405 0.986643 0.784929 0.720869 0.142356 0.321014 -0.264424 1.700672 1.171217 1.168722 0.911571 0.897262 1.490697 0.828456 1.047805 0.694648 0.985672 0.794358 1.062298 1.103188 1.595006 1.521040 1.764525 -0.106047 0.016946 0.120669 0.643435 1.011018 1.433782 0.064397 0.052151 0.670043 1.097438 1.450840 1.829744)
+ 9.145844 #(0.000000 0.566683 1.107648 1.906025 0.221947 0.832929 1.646883 0.003598 0.594983 1.443215 0.059329 0.776514 1.650354 0.526476 1.163785 -0.073477 1.002422 -0.002389 1.070033 0.044031 0.784449 1.327277 0.487633 1.314288 0.580998 1.768047 0.897468 -0.079923 0.817793 0.129615 1.548420 0.755157 0.047436 0.933698 0.072836 1.838297 1.394453 0.409694 1.883124 1.411951 0.367286 1.559580 1.347795 0.901907 0.261118 1.614248 1.386396 1.030092 0.495139 -0.244679 1.429057 1.095949 0.954289 0.796818 0.700395 0.130060 0.311501 -0.283703 1.698927 1.200401 1.111917 0.896911 0.863583 1.501476 0.795659 1.065652 0.706914 0.954080 0.738520 1.047306 1.097502 1.582249 1.456216 1.733897 -0.138892 -0.037173 0.099865 0.586472 1.000632 1.405077 0.060430 -0.004754 0.633209 1.032431 1.436909 1.788117)
+ 9.144898 #(0.000000 0.553220 1.114143 1.907542 0.232990 0.842372 1.638290 0.002415 0.600151 1.441766 0.072607 0.770701 1.630141 0.524050 1.166300 -0.060704 0.988063 -0.011935 1.056235 0.044313 0.796954 1.351344 0.491264 1.317927 0.594365 1.770310 0.908994 -0.083046 0.803658 0.111996 1.532402 0.759402 0.036170 0.943179 0.079272 1.830583 1.382504 0.397346 1.856130 1.407405 0.379257 1.552501 1.336822 0.894256 0.259512 1.640642 1.404950 1.043723 0.498578 -0.255562 1.439871 1.113214 0.957074 0.794912 0.690668 0.138597 0.312164 -0.286212 1.710429 1.181779 1.119942 0.882351 0.853742 1.507047 0.801407 1.064423 0.722928 0.946894 0.773817 1.034859 1.074112 1.587958 1.477366 1.754829 -0.141780 -0.019862 0.118652 0.596035 1.023862 1.396961 0.052731 -0.006814 0.649298 1.055665 1.431062 1.786776)
)
;;; 87 all -------------------------------------------------------------------------------- ; 9.3274
@@ -1033,7 +1076,8 @@
9.336088 (fv 0.000000 0.935303 -0.305855 0.639666 -0.205066 0.575166 1.878633 -0.031633 0.332111 0.265245 0.447761 1.471005 0.466239 1.074654 0.243517 0.903095 0.071080 0.582837 0.986978 1.432105 0.143848 1.529993 0.888064 0.154620 1.746534 1.298224 1.092204 0.252914 1.241973 -0.114644 0.118634 1.005127 -0.195946 0.639640 0.754289 -0.065632 0.714364 1.300342 0.839106 1.256746 0.582262 1.885531 1.298010 0.384388 0.185574 1.168220 1.586291 1.242180 1.296083 0.391273 0.262871 0.811036 0.806565 0.431451 1.015342 1.630813 1.685662 -0.062763 0.311437 -0.322103 1.934808 -0.217239 0.478902 -0.218460 1.046362 0.603169 1.523851 1.302931 0.360083 0.678610 0.838126 1.626723 0.408089 0.150785 0.439104 0.575446 0.524826 1.662738 0.111387 1.179455 0.712858 0.531389 0.286195 0.456407 0.251572 1.398780 1.753711)
;; pp:start point was (pp.scm, make-pp.scm): pi+pi/87 and -pi/2
- 9.201148 (fv 0.000000 0.606264 1.286641 1.633640 0.300135 0.826873 1.570361 0.039518 0.674212 1.390759 0.031099 0.782113 1.606099 0.456663 1.310938 -0.012755 1.011947 1.962275 1.031324 1.924212 0.700369 1.463259 0.449090 1.418882 0.516579 1.837916 1.056960 -0.026846 1.090144 0.187208 1.379580 0.694876 0.055771 0.972409 0.040906 1.575865 1.149936 0.410530 1.850809 1.237404 0.345035 1.553764 1.235369 0.825540 0.101389 1.583999 1.336472 0.955112 0.350910 -0.239863 1.473194 1.184033 1.132454 0.656789 0.797039 0.036147 0.315231 -0.255734 1.842540 1.250679 1.177721 1.108481 0.895012 1.358540 0.880609 0.969577 0.756153 1.004262 0.902032 1.003387 1.132762 1.561102 1.534103 1.804297 0.070209 -0.024117 0.069086 0.402650 0.873594 1.402800 1.716632 1.930312 0.453843 0.755753 1.442497 1.742394 -0.135628)
+ 9.188521 #(0.000000 0.577038 1.207261 1.628557 0.262146 0.801237 1.556050 0.056439 0.667335 1.368629 -0.005675 0.749653 1.604613 0.459413 1.321111 -0.031172 1.051217 -0.021196 1.026933 1.909174 0.730842 1.464699 0.478663 1.424779 0.531386 1.829514 1.099308 0.030309 1.091452 0.183625 1.427990 0.713707 0.072882 0.988307 0.050871 1.569876 1.182625 0.368506 1.869531 1.283013 0.367839 1.495424 1.258194 0.820412 0.120239 1.561194 1.309622 0.929536 0.337985 -0.260353 1.473059 1.175804 1.110077 0.673201 0.814863 -0.004594 0.327741 -0.246652 1.781940 1.248926 1.174864 1.075991 0.895836 1.403691 0.903960 0.895504 0.766042 1.020851 0.881318 1.007885 1.155350 1.590758 1.540581 1.812457 0.004350 -0.049652 0.077880 0.408393 0.883302 1.419937 1.752252 -0.010350 0.469666 0.737948 1.471230 1.731975 -0.094827)
+ 9.187891 #(0.000000 0.562265 1.215132 1.639989 0.268408 0.803228 1.556396 0.052662 0.673897 1.370427 -0.013341 0.755625 1.613682 0.464097 1.303388 -0.037077 1.034992 -0.022117 1.014610 1.893157 0.718728 1.483506 0.494314 1.442488 0.545375 1.834445 1.096157 0.044881 1.127012 0.215102 1.425993 0.718653 0.082596 0.974151 0.052799 1.587090 1.187190 0.360476 1.852622 1.250947 0.372936 1.523300 1.264181 0.805702 0.081155 1.558372 1.276806 0.921107 0.347174 -0.241287 1.479655 1.180393 1.125004 0.659710 0.822627 -0.001295 0.310451 -0.262271 1.777140 1.247104 1.177750 1.114372 0.920013 1.374146 0.894221 0.877518 0.741864 1.020196 0.885904 1.001071 1.161793 1.551252 1.536508 1.802169 0.022015 -0.071435 0.050557 0.417817 0.866824 1.426867 1.751719 0.013618 0.498761 0.731015 1.470154 1.720066 -0.074032)
)
;;; 88 all -------------------------------------------------------------------------------- ; 9.3808
@@ -1042,7 +1086,8 @@
9.316523 (fv 0.000000 0.878486 0.456733 1.616494 0.833842 1.630288 0.213084 0.318066 0.387075 1.258199 0.888074 1.626323 1.385324 1.449641 1.788877 1.459694 0.074476 0.796586 0.333918 0.652336 0.086019 1.093159 0.327760 0.026729 0.468210 0.200167 0.537074 1.539924 -0.274885 1.353211 0.267108 0.236471 1.407050 0.990605 0.724714 0.464124 0.495860 1.314621 -0.030616 0.350065 0.839694 0.794947 -0.082046 0.540462 1.600245 0.715450 0.591095 1.608103 0.808561 1.476715 1.175725 0.089220 0.447550 -0.172825 1.173712 -0.287102 0.416439 1.195370 1.285929 1.007325 0.957271 -0.013128 1.194681 1.765216 1.741310 1.202198 1.235154 1.112410 1.116838 1.017962 0.227564 0.013993 0.930616 0.757675 -0.297628 0.560900 0.173387 0.493968 1.241443 0.533916 1.114281 1.119507 0.538020 0.529723 1.672789 1.594826 0.538626 1.278733)
;; 87 + 1 (pp)
- 9.255901 #(0.000000 0.704719 1.188893 1.675767 0.096018 0.845936 1.487824 0.078995 0.667889 1.297691 -0.023647 0.780968 1.603472 0.340759 1.204870 0.026757 1.150149 0.124316 1.065077 1.884618 0.609326 1.416953 0.372499 1.356073 0.453572 1.767703 1.001278 -0.238843 0.931840 0.205018 1.420053 0.675690 0.112242 1.052571 0.089462 1.485924 1.236180 0.407150 1.816803 1.284565 0.400450 1.410505 1.095373 0.831937 0.217112 1.631168 1.291427 1.030080 0.299217 -0.282356 1.506750 1.204044 1.185604 0.656589 0.898458 0.004864 0.154258 -0.340896 1.825973 1.369257 1.104084 0.921755 0.900302 1.295845 0.824555 1.094591 0.785023 1.079180 0.885480 0.926136 0.942138 1.655789 1.435560 1.812571 -0.053178 0.016700 0.075866 0.223760 0.836926 1.243772 1.565476 1.835913 0.515899 0.597634 1.438547 1.710832 -0.154189 0.323632)
+ 9.244078 #(0.000000 0.694018 1.165822 1.676512 0.096734 0.820300 1.468057 0.088341 0.655120 1.291453 -0.067834 0.750649 1.606715 0.366794 1.199710 0.067953 1.171063 0.125791 1.077914 1.904683 0.572953 1.438964 0.387785 1.361027 0.470626 1.798354 1.025608 -0.183300 0.935453 0.193835 1.423867 0.670497 0.056060 1.040746 0.102123 1.502090 1.195959 0.413063 1.791619 1.270627 0.359281 1.413426 1.078876 0.807816 0.227637 1.617604 1.316579 0.989646 0.288255 -0.228378 1.516380 1.207792 1.225064 0.737215 0.935014 0.031773 0.170020 -0.334787 1.865610 1.331909 1.164836 0.934833 0.925908 1.288654 0.798848 1.076323 0.722509 1.032823 0.879278 0.906937 0.934088 1.637290 1.478240 1.745733 -0.031866 -0.004141 0.054848 0.181925 0.776139 1.296456 1.577696 1.832552 0.546057 0.624987 1.395395 1.680089 -0.150964 0.305296)
+ 9.243448 #(0.000000 0.697851 1.166665 1.665599 0.098169 0.813468 1.475112 0.101377 0.652595 1.273039 -0.081569 0.745524 1.591625 0.353099 1.188181 0.067828 1.161595 0.152496 1.082314 1.900802 0.588773 1.446857 0.379192 1.369274 0.475586 1.801340 1.037627 -0.178925 0.939324 0.188566 1.443075 0.665312 0.046982 1.052243 0.101080 1.498797 1.207289 0.409569 1.784327 1.271339 0.376759 1.422106 1.059422 0.802437 0.209481 1.613077 1.299497 0.983704 0.306573 -0.235197 1.532651 1.198072 1.226923 0.712611 0.934064 0.028480 0.165446 -0.347088 1.856068 1.322916 1.165417 0.930692 0.903535 1.267764 0.795402 1.061438 0.706954 1.032722 0.865689 0.907087 0.916387 1.610361 1.471937 1.742343 -0.052496 -0.040631 0.057803 0.155675 0.765103 1.291462 1.566099 1.820302 0.538939 0.627227 1.392483 1.674330 -0.144452 0.267627)
)
;;; 89 all -------------------------------------------------------------------------------- ; 9.4340
@@ -1051,8 +1096,8 @@
9.351480 (fv 0.000000 0.115345 0.952969 1.130622 0.084058 0.254252 0.443202 0.470071 0.932794 0.466331 0.591979 0.457396 1.528107 0.715257 1.847307 0.403253 0.673874 1.456603 0.267262 0.304798 0.064020 -0.007350 0.259234 -0.287472 0.913317 0.595047 1.491194 0.951199 1.469407 0.524123 -0.304693 -0.076445 1.827209 1.059199 1.449793 1.495662 0.754984 0.852314 0.216817 0.724819 0.597427 1.273980 0.926620 0.643916 0.066061 0.625597 1.284699 0.657854 0.605911 1.653365 1.442076 1.033587 -0.542590 1.262635 1.257414 1.117301 0.126208 0.112501 1.272548 0.912632 0.005045 0.757226 0.049364 -0.033316 1.800311 -0.300949 0.310947 1.267820 0.529700 0.817110 -0.265053 1.152779 -0.048439 0.296709 1.270792 1.398568 -1.703554 0.050635 0.940556 0.440806 1.384526 0.885947 -0.609539 0.281434 0.391260 0.168064 1.027217 1.891400 0.923378)
;; 90-1:
- 9.322408 #(0.000000 0.087378 0.601494 0.619045 0.520565 0.192831 1.612417 1.279546 0.906053 0.457737 0.527283 0.437611 -0.272512 1.874208 1.597992 1.409776 1.395697 1.186577 1.086526 1.009432 1.136012 1.350067 1.144909 1.313540 1.533071 1.215995 1.081919 1.612408 1.898244 0.017826 0.553763 0.358095 0.618098 0.619590 1.152026 1.444621 1.376277 1.371746 0.475136 0.610211 1.154551 1.450756 1.825969 0.720349 1.002339 1.015582 1.779811 -0.009618 0.773423 1.486991 0.489018 0.816238 1.366259 -0.141599 0.467276 1.257869 0.320233 0.863396 -0.043865 0.225559 1.375686 0.193795 1.432403 0.122460 0.896371 1.257467 0.544644 1.620326 1.065587 0.154166 0.693743 -0.000523 0.966448 0.011206 0.776220 -0.165885 1.230078 0.317955 1.642970 1.105363 -0.006317 1.325943 0.779924 0.349832 1.497132 1.504927 0.446970 0.172096 1.705193)
- 9.320140 #(0.000000 0.085732 0.602185 0.617175 0.522197 0.190997 1.611235 1.274110 0.904142 0.452835 0.528448 0.436361 -0.269442 1.875946 1.604690 1.410246 1.390954 1.185226 1.083722 1.011452 1.135590 1.350393 1.145416 1.310658 1.529711 1.210268 1.075280 1.616587 1.889615 0.017964 0.548241 0.362206 0.608718 0.620881 1.136435 1.437719 1.368805 1.361704 0.470220 0.611816 1.147835 1.452097 1.805611 0.720099 1.006618 1.019936 1.776678 -0.022447 0.775934 1.492975 0.482909 0.813476 1.367056 -0.142436 0.453330 1.253107 0.316399 0.860587 -0.029985 0.219767 1.368874 0.195670 1.423338 0.128208 0.885181 1.249081 0.542164 1.611389 1.068132 0.152847 0.699013 0.000977 0.975096 0.009537 0.780185 -0.175101 1.220930 0.302282 1.634100 1.108302 -0.008121 1.320665 0.766574 0.346841 1.493147 1.498406 0.444256 0.163379 1.706039)
+ 9.316853 #(0.000000 0.085819 0.605350 0.616151 0.515100 0.192006 1.611678 1.272280 0.904547 0.453867 0.529558 0.437126 -0.275887 1.872898 1.598164 1.418346 1.396886 1.184855 1.082655 1.009362 1.135722 1.346642 1.144862 1.310841 1.530764 1.205966 1.069809 1.617371 1.901283 0.014975 0.548240 0.352080 0.621455 0.621066 1.140982 1.438527 1.367420 1.355216 0.470090 0.621128 1.153118 1.453426 1.808321 0.722632 1.010390 1.016431 1.780248 -0.019572 0.772427 1.493792 0.482571 0.820743 1.364914 -0.136038 0.461117 1.249099 0.311482 0.865776 -0.039503 0.219768 1.361786 0.194309 1.428040 0.130391 0.884203 1.244022 0.541300 1.606196 1.062028 0.148664 0.708408 0.000808 0.975685 0.011180 0.773834 -0.174375 1.225192 0.298080 1.628234 1.104559 -0.010457 1.317133 0.763549 0.343844 1.496091 1.494316 0.445462 0.157345 1.694775)
+ 9.315509 #(0.000000 0.124567 0.583351 0.597843 0.508932 0.236340 1.629251 1.260618 0.886324 0.407100 0.532057 0.464552 -0.228622 1.874560 1.586831 1.454279 1.336216 1.166281 1.089863 0.976652 1.146549 1.384070 1.107271 1.259583 1.540352 1.231987 1.112399 1.654619 1.894205 0.035892 0.522606 0.318613 0.597511 0.620237 1.103293 1.435193 1.365285 1.347328 0.516939 0.607227 1.150990 1.407334 1.775681 0.771851 0.945166 0.989030 1.801909 0.000987 0.826555 1.547883 0.480169 0.802373 1.360513 -0.158813 0.514706 1.271439 0.393074 0.883929 -0.039924 0.249141 1.389995 0.169046 1.414692 0.200776 0.896962 1.236745 0.582426 1.647885 1.121990 0.246958 0.721303 0.009183 0.987717 0.027886 0.854020 -0.153681 1.227081 0.324522 1.691772 1.126527 -0.020392 1.310045 0.754076 0.386463 1.500700 1.504277 0.417697 0.239864 1.723507)
)
;;; 90 all -------------------------------------------------------------------------------- ; 9.4868
@@ -1231,8 +1276,8 @@
10.273899 (fv 0.000000 1.285870 0.722685 1.695642 1.789973 0.495199 0.001511 0.648393 1.565696 0.756830 0.421656 -0.184836 0.187469 1.381401 1.501800 0.551266 1.079110 0.129360 0.283265 1.059394 -0.217105 1.758613 1.156467 0.305791 0.018881 1.709795 1.386465 1.716357 0.543922 -0.077767 0.376814 1.917356 1.703183 0.375846 1.314995 1.049255 -0.015490 1.182770 0.105614 1.125738 1.580574 0.196175 0.043631 0.176951 1.523484 1.504279 0.024743 0.233174 0.051990 0.885176 0.485127 0.978870 1.366279 1.841166 1.225239 0.599047 0.937430 1.422432 0.950869 1.195765 0.360876 1.187450 1.491233 0.274262 0.123358 1.276789 1.498182 1.151090 1.495794 1.385360 0.511524 1.320969 1.040843 1.323508 0.526850 1.486006 0.358172 -0.084804 0.784722 0.263761 0.033435 1.669885 0.179635 1.097636 0.771172 0.674320 0.095788 1.426496 1.763465 0.078301 1.972016 1.520526 1.431005 0.272982 0.550020 1.118797 -0.453975 1.686563 1.286924 1.481496 1.458102 0.550556 0.115818 1.002355 0.493193 0.718245 1.621218)
;; 105+2 = 103+4
- 10.264612 #(0.000000 0.514224 0.665359 0.437182 0.342816 -0.368387 0.867170 1.680316 -0.035238 0.578630 0.393687 0.938896 -0.024374 -0.189156 0.035454 0.187626 1.668105 0.892639 1.570971 -0.276314 -0.041612 1.538700 0.575011 1.442591 1.128708 -0.096511 0.254928 1.337942 1.315964 0.935516 0.311726 0.253932 1.021526 1.268822 -0.023742 0.192028 -0.370923 1.506415 1.235486 1.032651 0.730433 -1.027437 0.230300 0.841525 1.268688 0.417647 -0.000948 0.997350 0.123998 1.172791 1.587045 0.633923 1.380769 1.634328 -0.214874 1.352466 1.164864 0.221440 1.321201 0.301078 1.532112 0.479377 1.263841 1.506446 0.979971 0.441986 0.145681 0.815023 -0.650102 1.205600 0.776509 1.020238 -0.283679 0.966039 0.145650 0.034616 -0.371329 0.803160 0.169955 1.683053 1.044817 -0.289624 -0.108629 0.452027 0.488696 0.786211 -0.208619 0.885069 1.098623 1.325857 0.780057 1.242131 0.812645 1.416037 0.467165 1.275112 -0.271849 0.464109 0.892644 0.500155 -0.131218 1.071176 0.890519 -0.502997 -0.497750 -0.438493 -0.169193)
- 10.258830 #(0.000000 0.574863 0.710649 0.509173 0.341705 -0.258603 0.827721 1.686497 0.043643 0.656999 0.401360 0.893339 -0.070537 -0.202877 0.146726 0.184347 1.723139 0.817529 1.582194 -0.235982 0.005561 1.455954 0.674079 1.352605 1.054095 -0.078206 0.213315 1.347753 1.318381 0.982781 0.354958 0.244635 0.967764 1.229868 0.031999 0.198154 -0.444690 1.565985 1.253320 1.055940 0.818868 -1.001331 0.183205 0.867393 1.254304 0.529154 0.062476 0.852551 0.183546 1.206638 1.616905 0.704326 1.451973 1.653828 -0.165437 1.359257 1.147685 0.230348 1.322073 0.342002 1.534217 0.472562 1.303407 1.493484 0.935931 0.519310 0.245942 0.859223 -0.594681 1.279503 0.739153 0.988145 -0.268491 0.963612 0.300691 0.003142 -0.262801 0.791987 0.206787 1.692192 1.027639 -0.307391 -0.108335 0.524530 0.487821 0.760637 -0.044761 0.812681 1.025608 1.312415 0.795498 1.359445 0.826687 1.362466 0.594357 1.199103 -0.267334 0.478113 0.924328 0.481065 -0.027388 1.086650 0.900592 -0.574983 -0.573938 -0.427218 -0.169596)
+ 10.254504 #(0.000000 0.484824 0.645093 0.484448 0.357958 -0.306335 0.781266 1.722221 -0.020523 0.622664 0.475686 0.971485 -0.081828 -0.221731 0.023546 0.160724 1.699779 0.877022 1.571254 -0.219251 0.072417 1.464813 0.631200 1.379055 1.117758 -0.133773 0.232309 1.351525 1.269800 0.970127 0.241075 0.257607 1.000838 1.216076 0.053471 0.232020 -0.359907 1.509993 1.179694 1.054758 0.827030 -1.018435 0.149201 0.847612 1.252524 0.455297 0.005091 0.938550 0.112714 1.231427 1.569945 0.646140 1.306245 1.559100 -0.235326 1.424717 1.086220 0.226398 1.287381 0.237597 1.562146 0.408642 1.239694 1.521425 0.873908 0.443864 0.122845 0.794034 -0.670208 1.201438 0.763367 1.019610 -0.305283 0.938173 0.223614 0.151118 -0.405317 0.789769 0.185696 1.705170 1.080972 -0.394578 -0.084190 0.462333 0.451070 0.732074 -0.196625 0.882445 1.029212 1.285492 0.753537 1.256080 0.793604 1.367897 0.491589 1.208211 -0.307546 0.448608 0.892802 0.520730 -0.067668 1.081080 0.866532 -0.521852 -0.524522 -0.470753 -0.243216)
+ 10.250733 #(0.000000 0.483912 0.644703 0.485457 0.358095 -0.305666 0.780949 1.722379 -0.020746 0.621961 0.474887 0.971799 -0.081593 -0.221790 0.024110 0.159431 1.699382 0.876421 1.571715 -0.219801 0.072621 1.464672 0.630752 1.380382 1.117163 -0.134137 0.232594 1.352288 1.269630 0.968806 0.240910 0.258155 1.001406 1.216432 0.053369 0.232245 -0.359904 1.509850 1.180087 1.054981 0.826371 -1.018830 0.149841 0.846847 1.251712 0.455512 0.004303 0.938417 0.112890 1.231211 1.569892 0.646448 1.305537 1.558830 -0.235146 1.425032 1.086297 0.226783 1.288076 0.237137 1.561589 0.408735 1.240009 1.521331 0.873481 0.444503 0.123500 0.794180 -0.670582 1.202161 0.762118 1.019326 -0.305420 0.938305 0.222385 0.150427 -0.405430 0.790658 0.185984 1.703676 1.080860 -0.394708 -0.083973 0.462509 0.451296 0.730919 -0.196866 0.882952 1.029031 1.285788 0.753984 1.256801 0.794497 1.368238 0.490612 1.208438 -0.307623 0.448339 0.892856 0.519789 -0.067328 1.081789 0.866642 -0.521116 -0.524606 -0.471314 -0.243671)
)
;;; 108 all -------------------------------------------------------------------------------- ; 10.3923
@@ -1241,8 +1286,8 @@
10.312988 (fv 0.000000 1.293654 0.754043 1.806542 1.109001 0.766775 1.436021 1.627340 0.528605 1.806494 1.181378 0.013554 0.353388 0.092480 0.431618 0.200495 0.904126 0.741464 0.675051 -0.110957 1.146773 1.810641 0.552983 0.275055 0.835876 1.123930 -0.182193 -0.339155 0.645146 0.163632 0.868047 1.269556 0.830686 1.219557 1.665806 1.060039 1.944315 -0.011848 0.365415 0.718256 0.624511 1.571990 0.113371 0.572031 1.797961 0.876379 0.068642 0.072119 0.553161 0.329387 0.545574 0.337595 1.647194 1.034042 0.468339 1.774314 0.240404 1.846502 1.142528 1.223731 0.832499 0.428931 0.643890 1.257704 1.085969 0.643637 0.429070 0.971966 0.109095 0.689833 0.417898 1.804672 1.346983 0.150026 0.404292 0.575881 1.441149 0.533070 -0.177095 0.298641 0.921545 1.086883 0.410704 0.849120 1.518187 1.874571 0.517824 1.242109 -0.053714 0.834159 0.276990 1.956354 1.765190 1.537622 1.530954 -0.106766 1.325278 -0.071959 1.045056 0.533410 0.699958 0.068418 0.070057 1.204618 1.620552 1.072110 1.372120 0.848823)
;; 103+5
- 10.374947 #(0.000000 0.662339 0.669289 0.531784 0.392339 -0.487364 0.675984 1.450839 0.161241 0.606092 0.594508 0.957385 0.057680 0.014652 0.220997 0.348879 1.603675 0.790978 1.705154 -0.137396 -0.198596 1.586401 0.726590 1.454575 1.399518 -0.206849 0.214718 1.311202 1.330318 0.855445 0.730970 0.492104 0.709457 0.869844 0.240430 0.326572 -0.219863 1.541532 1.358838 1.328103 0.876125 -0.864476 0.220602 1.023093 1.583629 0.603693 -0.281458 1.247304 0.173858 1.272146 1.547201 0.868617 1.202148 1.566443 -0.265227 1.475538 1.126832 0.442072 1.272975 0.069743 1.608569 0.546375 1.729787 -0.165266 1.244618 0.434472 0.280333 0.487761 -0.045704 1.380884 0.731120 0.869899 -0.062065 1.238076 -0.181995 0.375944 -0.599288 1.052764 0.185947 1.610670 1.114319 -0.459327 -0.081027 0.072067 0.570945 0.780858 0.208049 0.664110 1.308748 1.451123 0.574459 1.287385 0.565553 1.601243 0.555906 1.166221 -0.072585 0.321487 1.099870 0.756450 0.016973 1.247515 0.826123 -0.483806 -0.505822 -0.111992 -0.050341 0.277622)
- 10.366958 #(0.000000 0.662251 0.670071 0.534968 0.390769 -0.487492 0.676412 1.452624 0.159875 0.606901 0.595543 0.956937 0.059026 0.011015 0.223033 0.349504 1.604402 0.791507 1.705129 -0.138244 -0.198943 1.586770 0.728435 1.456034 1.399704 -0.206504 0.216513 1.310164 1.330934 0.855469 0.728598 0.492931 0.709221 0.867021 0.242327 0.325006 -0.218785 1.543222 1.356338 1.327603 0.876469 -0.863391 0.220009 1.022662 1.583744 0.605894 -0.280755 1.246294 0.173429 1.274126 1.548489 0.867987 1.203052 1.564818 -0.264731 1.474519 1.125297 0.442497 1.273224 0.068873 1.609204 0.547852 1.727712 -0.165089 1.242479 0.435346 0.278407 0.487182 -0.045296 1.381315 0.729883 0.869821 -0.063016 1.238543 -0.181664 0.377990 -0.600131 1.054236 0.187515 1.612190 1.112474 -0.459367 -0.080814 0.068618 0.572010 0.780117 0.207856 0.662783 1.308574 1.451137 0.575486 1.289353 0.567156 1.600155 0.556068 1.167633 -0.072487 0.322513 1.100221 0.757263 0.020228 1.247118 0.824014 -0.483968 -0.504566 -0.113982 -0.049005 0.275202)
+ 10.360302 #(0.000000 0.551674 0.684121 0.443843 0.328287 -0.382856 0.742347 1.553271 0.100438 0.588495 0.564972 0.863601 0.125393 0.057318 -0.071985 0.287901 1.600093 0.971407 1.645285 -0.209518 -0.381267 1.448278 0.742196 1.379192 1.304893 -0.172568 0.425075 1.236069 1.368334 0.874268 0.672828 0.415281 0.726658 0.862117 0.109198 0.219337 -0.244418 1.532842 1.163405 1.346937 0.978237 -0.950485 0.281930 0.924923 1.513033 0.583840 -0.415504 1.174086 0.188477 1.112313 1.589792 0.899949 1.271439 1.538926 -0.265428 1.460427 1.161403 0.396214 1.349937 0.135151 1.479429 0.399645 1.649047 -0.124860 1.280184 0.464971 0.347605 0.600275 -0.139067 1.236147 0.852840 0.641047 -0.107564 1.211289 -0.076869 0.330831 -0.638295 0.950296 0.142049 1.425529 1.211169 -0.161554 0.129139 0.243541 0.647760 0.753493 0.224072 0.686712 1.456555 1.430413 0.867180 1.349952 0.357062 1.696651 0.627351 1.338698 0.006006 0.515509 1.152554 0.609264 -0.153967 1.271052 0.732750 -0.451261 -0.621127 -0.054294 -0.063774 0.634645)
+ 10.344504 #(0.000000 0.554177 0.686603 0.442963 0.330457 -0.383506 0.740825 1.555486 0.100826 0.588922 0.565702 0.862938 0.127067 0.056740 -0.069899 0.290177 1.602316 0.972504 1.644788 -0.208407 -0.383569 1.450051 0.741146 1.377401 1.305410 -0.168825 0.428117 1.236110 1.367696 0.873985 0.672701 0.413093 0.726218 0.861358 0.109862 0.215210 -0.240642 1.530834 1.163848 1.343976 0.980851 -0.948698 0.281660 0.923527 1.516228 0.584674 -0.414222 1.172500 0.191678 1.113538 1.586368 0.900806 1.270747 1.537958 -0.265025 1.461949 1.160460 0.395671 1.350152 0.136808 1.485285 0.401359 1.654233 -0.123106 1.280806 0.466879 0.345278 0.597993 -0.139606 1.239204 0.851600 0.644182 -0.102185 1.210948 -0.076698 0.332547 -0.640955 0.952129 0.142937 1.428164 1.214644 -0.163426 0.128350 0.239573 0.645480 0.752936 0.225706 0.687169 1.460909 1.432454 0.869137 1.348779 0.361743 1.699109 0.623957 1.337938 0.001013 0.515906 1.149085 0.609013 -0.152564 1.271041 0.737876 -0.454840 -0.623700 -0.054225 -0.061354 0.631795)
)
;;; 109 all -------------------------------------------------------------------------------- ; 10.440306508911
@@ -1628,24 +1673,31 @@
(vector 20 5.043 (fv 0 1 0 1 0 0 0 0 0 0 1 0 1 1 0 0 0 1 1 0)
4.357980 (fv 0.000000 0.074668 -0.007236 0.182274 -0.090904 0.683075 1.087950 1.620610 1.402047 0.349796 1.096502 -0.498958 0.949574 -0.321894 1.411823 0.831379 -0.654670 0.294879 -0.284984 1.407225)
+ 4.356656 #(0.000000 0.044744 -0.047981 0.128863 -0.150103 0.595893 0.996459 1.503334 1.271777 0.210796 0.941585 -0.676423 0.753934 -0.518223 1.199582 0.603645 -0.895309 0.041564 -0.570764 1.114521)
+ 4.355995 #(0.000000 0.024523 -0.077981 0.094701 -0.185914 0.535056 0.941202 1.418233 1.182050 0.122672 0.835173 -0.794144 0.620245 -0.650040 1.051946 0.447935 -1.057769 -0.131937 -0.767349 0.907729)
)
;;; 21 odd -------------------------------------------------------------------------------- ; 4.5825756
(vector 21 5.1372244578347 (fv 0 1 1 1 0 0 0 0 1 1 1 0 1 1 1 1 0 1 1 0 1)
4.448460 (fv 0.000000 1.232455 0.090847 0.908719 0.292484 1.788804 -0.065161 1.337389 1.076226 0.741452 1.053336 1.212537 1.463874 0.812811 1.503269 1.665124 0.651549 0.032446 1.058206 1.235365 -0.036822)
+ 4.447712 #(0.000000 1.220427 0.045293 0.858629 0.231429 1.700142 -0.160980 1.218894 0.949798 0.603291 0.899651 1.035822 1.269858 0.612061 1.290837 1.429732 0.418061 -0.221908 0.767727 0.941622 -0.345580)
)
;;; 22 odd -------------------------------------------------------------------------------- ; 4.6904157
(vector 22 5.1805551751198 (fv 0 1 0 1 0 1 0 0 1 0 1 1 0 0 1 1 0 0 0 0 0 0)
4.581017 (fv 0.000000 0.180996 0.414015 1.937535 0.354831 0.584078 1.521008 1.778595 1.533807 1.338106 -0.034930 1.700610 0.808153 0.348626 1.850606 -0.102689 0.038967 0.664253 1.395687 0.513457 1.627689 0.472162)
+ 4.579257 #(0.000000 0.160145 0.376968 1.878139 0.284740 0.487496 1.415433 1.651566 1.394773 1.183605 -0.193956 1.531888 0.608672 0.136531 1.618492 -0.352713 -0.215925 0.386438 1.100273 0.216695 1.305644 0.124351)
+ 4.578852 #(0.000000 0.154050 0.362874 1.858028 0.259714 0.456041 1.377794 1.607955 1.346684 1.127150 -0.251090 1.469023 0.539758 0.060029 1.535419 -0.438194 -0.308160 0.292150 0.997798 0.111637 1.191665 0.001305)
)
;;; 23 odd -------------------------------------------------------------------------------- ; 4.7958315
(vector 23 5.4125407453101 (fv 0 0 0 1 1 1 1 0 0 1 0 1 0 1 1 1 1 0 1 1 0 0 1)
4.661614 (fv 0.000000 0.402662 0.143299 -0.307618 -0.213995 0.796949 1.006633 1.285380 1.569840 0.564104 0.342477 0.293161 1.200899 0.723618 0.539973 0.518746 0.907665 0.184015 1.163786 0.995418 -1.860771 1.039418 -0.124574)
+ 4.658390 #(0.000000 0.419962 0.178288 -0.267818 -0.157520 0.874624 1.093455 1.384101 1.676081 0.681110 0.477454 0.442373 1.355797 0.900490 0.720817 0.711944 1.110707 0.407242 1.398561 1.238977 -1.594245 1.310605 0.162743)
+ 4.657663 #(0.000000 0.426179 0.187628 -0.253909 -0.133844 0.893467 1.114444 1.407608 1.699926 0.710638 0.510068 0.482278 1.406393 0.953421 0.771560 0.766163 1.164739 0.476423 1.464465 1.310299 -1.522425 1.393778 0.244012)
)
;;; 24 odd -------------------------------------------------------------------------------- ; 4.89897948
@@ -1658,18 +1710,21 @@
(vector 25 5.7220960914079 (fv 0 1 0 0 0 0 0 1 0 1 0 0 1 0 1 1 1 0 1 1 0 0 0 1 1)
4.886819 (fv 0.000000 -0.128793 0.647898 0.792536 -0.285146 0.144218 1.160103 1.183437 -0.004858 -0.239530 1.215352 0.277973 0.699697 1.110172 0.616181 1.458993 0.406636 0.121039 0.182656 -0.085662 1.058149 0.147121 0.546131 0.378165 0.309175)
+ 4.886236 #(0.000000 -0.128178 0.652568 0.797088 -0.275959 0.158174 1.174061 1.197383 0.009935 -0.214485 1.240655 0.302787 0.729528 1.140096 0.651272 1.495962 0.448573 0.161613 0.223277 -0.039067 1.103972 0.193914 0.595377 0.436930 0.366454)
)
;;; 26 odd -------------------------------------------------------------------------------- ; 5.0990
(vector 26 5.8537594936002 (fv 0 0 0 0 1 1 1 1 0 0 1 0 0 1 0 0 1 1 1 0 1 1 1 1 0 1)
5.006443 (fv 0.000000 1.694135 1.368613 1.372881 0.625230 0.749494 1.218456 1.691757 1.088538 0.652397 -0.134215 1.088115 0.314540 0.197061 0.715518 1.230349 1.542812 -0.159343 1.427261 1.767442 0.867761 1.850745 0.671024 -0.112496 0.172562 0.147817)
+ 5.006036 #(0.000000 1.696557 1.372055 1.375045 0.631786 0.755711 1.226707 1.702261 1.098629 0.662269 -0.123532 1.099469 0.328115 0.211696 0.733087 1.251115 1.560506 -0.139299 1.445624 1.791126 0.890231 1.877406 0.695750 -0.085832 0.201983 0.175784)
)
;;; 27 odd -------------------------------------------------------------------------------- ; 5.196152
(vector 27 5.8637111082051 (fv 0 0 1 1 0 0 1 0 1 0 0 1 0 1 0 0 0 1 0 0 0 0 0 1 1 1 1)
5.088823 (fv 0.000000 0.108028 1.216984 1.164689 0.975005 -0.022884 0.035464 -0.148996 0.575654 1.005987 1.378471 0.117457 0.956928 1.741009 0.131397 -0.243584 0.873140 0.514628 1.810242 0.918281 0.161062 1.222969 1.595595 1.233298 1.211975 1.332117 1.297417)
+ 5.087482 #(0.000000 0.116642 1.233386 1.188837 1.007458 0.013222 0.081718 -0.090927 0.635200 1.079532 1.458945 0.207268 1.054227 1.843692 0.235599 -0.128212 0.993227 0.637850 1.940984 1.056899 0.307631 1.374291 1.769589 1.398353 1.398430 1.518174 1.491390)
)
;;; 28 odd -------------------------------------------------------------------------------- ; 5.291502
@@ -4483,15 +4538,14 @@
(define (get-best choice n)
(let ((func (lambda (val)
- (and val
- (vector? val)
+ (and (vector? val)
(= (val 0) n)
(let ((a-val (val 1))
(a-len (length val))
(a-data (val 2)))
(do ((k 3 (+ 1 k)))
((= k a-len))
- (if (and (number? (val k))
+ (if (and (real? (val k))
(< (val k) a-val))
(begin
(set! a-val (val k))
@@ -4791,8 +4845,9 @@
;; 1 Mar 4151.007
;; 1 Apr 4150.840
;; 1 May 4150.665
+;; 1 Jun 4150.537
-; all 0.4860 (20) to 0.4986 (125), dist: 0.0000, 14.9637
+; all 0.4860 (20) to 0.4986 (125), dist: 0.0000, 15.0910
; odd 0.4820 (11) to 0.5000 (112), dist: 0.0000, 8.5572
; even 0.5085 (115) to 0.5242 (22), dist: 57.6719, 0.0000
; prime 0.5444 (24) to 0.5540 (67), dist: 232.5920, 0.0000
diff --git a/play.scm b/play.scm
index 129fa4c..b3fd19f 100644
--- a/play.scm
+++ b/play.scm
@@ -71,15 +71,14 @@
(define play-often
(let ((documentation "(play-often n) plays the selected sound 'n' times (interruptible via C-g)"))
(lambda (n)
- (define play-once
- (let ((plays (- n 1)))
- (lambda (reason)
- (if (and (> plays 0)
- (= reason 0))
- (begin
- (set! plays (- plays 1))
- (play (selected-sound) :start 0 :stop play-once))))))
- (play (selected-sound) :start 0 :stop play-once))))
+ (letrec ((play-once (let ((plays (- n 1)))
+ (lambda (reason)
+ (if (and (> plays 0)
+ (= reason 0))
+ (begin
+ (set! plays (- plays 1))
+ (play (selected-sound) :start 0 :stop play-once)))))))
+ (play (selected-sound) :start 0 :stop play-once)))))
;;(bind-key #\p 0 (lambda (n) "play often" (play-often (max 1 n))))
@@ -192,7 +191,7 @@ amp: (play-with-amps 0 1.0 0.5) plays channel 2 of stereo sound at half amplitud
((= i num-oscs))
(set! (frqs i) (hz->radians (car (freqs-and-amps i))))
(set! (amps i) (cadr (freqs-and-amps i))))
- (let ((ob (make-oscil-bank frqs (make-float-vector num-oscs 0.0) amps #t)))
+ (let ((ob (make-oscil-bank frqs (make-float-vector num-oscs) amps #t)))
(play (lambda ()
(and (positive? (set! len (- len 1)))
(oscil-bank ob)))))))))
diff --git a/poly.scm b/poly.scm
index 72d31f6..11e58fd 100644
--- a/poly.scm
+++ b/poly.scm
@@ -1,8 +1,6 @@
;;; polynomial-related stuff
;;;
;;; poly+ poly* poly/ poly-gcd poly-reduce poly-roots poly-derivative poly-resultant poly-discriminant
-;;;
-;;; this file really needs doubles (--with-doubles in configure, double as s7_double in s7.h)
(provide 'snd-poly.scm)
@@ -12,7 +10,7 @@
(complex (* mag (cos ang)) (* mag (sin ang)))
(error 'wrong-type-arg "make-polar args should be real"))))
-(define (vector->float-vector v) (copy v (make-float-vector (length v) 0.0)))
+(define (vector->float-vector v) (copy v (make-float-vector (length v))))
(define (float-vector->vector v) (copy v (make-vector (length v) 0.0)))
@@ -107,8 +105,7 @@
(vector-scale! (copy p1) p2)
(let* ((p1len (length p1))
(p2len (length p2))
- (len (+ p1len p2len))
- (m (make-vector len 0)))
+ (m (make-vector (+ p1len p2len) 0)))
(do ((i 0 (+ i 1)))
((= i p1len))
(do ((j 0 (+ j 1)))
@@ -202,7 +199,7 @@
(define (submatrix mx row col)
(let* ((old-n (car (vector-dimensions mx)))
(new-n (- old-n 1))
- (nmx (make-float-vector (list new-n new-n) 0.0)))
+ (nmx (make-float-vector (list new-n new-n))))
(do ((i 0 (+ i 1))
(ni 0))
((= i old-n))
@@ -249,7 +246,7 @@
(let* ((m (length p1))
(n (length p2))
(d (+ n m -2))
- (mat (make-float-vector (list d d) 0.0)))
+ (mat (make-float-vector (list d d))))
;; load matrix with n-1 rows of m's coeffs then m-1 rows of n's coeffs (reversed in sense), return determinant
(do ((i 0 (+ i 1)))
((= i (- n 1)))
@@ -401,8 +398,7 @@
(- (* a1 a3) (* 4 a0))
(- a2)
1.0))))
- (when (and yroot
- (pair? yroot)
+ (when (and (pair? yroot)
(= (length yroot) 4))
(do ((i 0 (+ i 1)))
((= i 3))
diff --git a/prc95.scm b/prc95.scm
index 480e5b5..d130f52 100644
--- a/prc95.scm
+++ b/prc95.scm
@@ -49,7 +49,7 @@
(float-vector 0.0 0.0))
(define (dc-block b samp)
- (set! (b 1) (+ samp (- (* 0.99 (b 1)) (b 0))))
+ (set! (b 1) (- (+ samp (* 0.99 (b 1))) (b 0)))
(set! (b 0) samp)
(b 1))
;; we could also use a filter generator here: (make-filter 2 (float-vector 1 -1) (float-vector 0 -0.99))
@@ -74,8 +74,7 @@
(definstrument (plucky beg dur freq amplitude maxa)
;; (with-sound () (plucky 0 .3 440 .2 1.0))
- (let* ((lowestfreq 100.0)
- (len (+ 1 (floor (/ *clm-srate* lowestfreq)))))
+ (let ((len (+ 1 (floor (/ *clm-srate* 100.0))))) ; 100 = lowest freq
(let ((delayline (make-delayl len (- (/ *clm-srate* freq) 0.5)))
(filt (make-onezero))
(start (seconds->samples beg))
@@ -94,8 +93,7 @@
(definstrument (bowstr beg dur frq amplitude maxa)
;; (with-sound () (bowstr 0 .3 220 .2 1.0))
- (let* ((lowestfreq 100.0)
- (len (+ 1 (floor (/ *clm-srate* lowestfreq)))))
+ (let ((len (+ 1 (floor (/ *clm-srate* 100.0))))) ; 100 = lowest freq
(let ((ratio 0.8317)
(rate .001)
(bowing #t)
@@ -126,9 +124,7 @@
(bowtemp 0.0))
(if bowing
(if (not (= maxvelocity bowvelocity))
- (set! bowvelocity (if (< bowvelocity maxvelocity)
- (+ bowvelocity attackrate)
- (- bowvelocity attackrate))))
+ (set! bowvelocity ((if (< bowvelocity maxvelocity) + -) bowvelocity attackrate)))
(if (> bowvelocity 0.0)
(set! bowvelocity (- bowvelocity attackrate))))
(set! bowtemp (* 0.3 bowvelocity))
@@ -150,8 +146,7 @@
(definstrument (brass beg dur freq amplitude maxa)
;; does this work at all?
- (let* ((lowestfreq 100.0)
- (len (+ 1 (floor (/ *clm-srate* lowestfreq)))))
+ (let ((len (+ 1 (floor (/ *clm-srate* 100.0)))))
(let ((blowing #t)
(rate .001)
(breathpressure 0.0)) ; 0.1 ?
@@ -169,9 +164,7 @@
((= i end))
(if blowing
(if (not (= maxpressure breathpressure))
- (set! breathpressure (if (< breathpressure maxpressure)
- (+ breathpressure attackrate)
- (- breathpressure attackrate))))
+ (set! breathpressure ((if (< breathpressure maxpressure) + -) breathpressure attackrate)))
(if (> breathpressure 0.0)
(set! breathpressure (- breathpressure attackrate))))
(set! dout (delayl delayline (dc-block dcblocker
@@ -189,8 +182,7 @@
(definstrument (clarinet beg dur freq amplitude maxa)
;; (with-sound () (clarinet 0 .3 440 .2 1.0))
- (let* ((lowestfreq 100.0)
- (len (+ 1 (floor (/ *clm-srate* lowestfreq)))))
+ (let ((len (+ 1 (floor (/ *clm-srate* 100.0)))))
(let ((blowing #t)
(breathpressure 0.0) ; 0.1 ?
(rate .001))
@@ -209,9 +201,7 @@
(let ((pressurediff 0.0))
(if blowing
(if (not (= maxpressure breathpressure))
- (set! breathpressure (if (< breathpressure maxpressure)
- (+ breathpressure attackrate)
- (- breathpressure attackrate))))
+ (set! breathpressure ((if (< breathpressure maxpressure) + -) breathpressure attackrate)))
(if (> breathpressure 0.0)
(set! breathpressure (- breathpressure attackrate))))
(set! pressurediff (- (one-zero filt (* -0.95 dlyout)) breathpressure))
@@ -230,8 +220,7 @@
(definstrument (flute beg dur freq amplitude maxa)
;; (with-sound () (flute 0 .3 440 .2 1.0))
- (let* ((lowestfreq 100.0)
- (len (+ 1 (floor (/ *clm-srate* lowestfreq)))))
+ (let ((len (+ 1 (floor (/ *clm-srate* 100.0)))))
(let ((jetrefl 0.6)
(endrefl 0.6)
(sinphase 0.0)
@@ -263,16 +252,11 @@
(set! randpressure (+ randpressure (* 0.05 breathpressure (sin sinphase))))
(if blowing
(if (not (= maxpressure breathpressure))
- (set! breathpressure (if (< breathpressure maxpressure)
- (+ breathpressure attackrate)
- (- breathpressure attackrate))))
+ (set! breathpressure ((if (< breathpressure maxpressure) + -) breathpressure attackrate)))
(if (> breathpressure 0.0)
(set! breathpressure (- breathpressure attackrate))))
(set! temp (dc-block dcblocker (one-pole filt boreout)))
- (set! pressurediff (+ (jettable
- (delayl jetdelay
- (+ breathpressure
- (- randpressure (* jetrefl temp)))))
+ (set! pressurediff (+ (jettable (delayl jetdelay (- (+ breathpressure randpressure) (* jetrefl temp))))
(* endrefl temp)))
(set! boreout (delayl boredelay pressurediff))
(outa i (* 0.3 amplitude boreout))
diff --git a/pvoc.scm b/pvoc.scm
index d982cf0..b124dbd 100644
--- a/pvoc.scm
+++ b/pvoc.scm
@@ -8,8 +8,7 @@
(lambda* (fftsize overlap interp analyze edit synthesize)
(let* ((N (or fftsize 512))
(N2 (floor (/ N 2)))
- (hop (or overlap 4))
- (D (floor (/ N hop))))
+ (D (floor (/ N (or overlap 4)))))
;; basic: fftsize overlap
;; everything else via closures (interp in particular)
@@ -245,9 +244,7 @@
(let* ((len (framples))
(filptr 0) ; index into the file
(pi2 (* 2 pi)) ; handy constant
- (sr (srate))
- (N fftsize) ; fft size
- (N2 (floor (/ N 2)))
+ (N2 (floor (/ fftsize 2)))
;; (Nw fftsize) ;; window size -- currently restricted to the fftsize
(D (floor (/ fftsize overlap))) ; decimation factor (how often do we take an fft)
(interp (* (floor (/ fftsize overlap)) time)) ; interpolation factor how often do we synthesize
@@ -255,29 +252,29 @@
(syngate (if (= 0.0 gate) 0.0 (expt 10 (/ (- (abs gate)) 20))))
(poffset (hz->radians hoffset))
(window (make-fft-window hamming-window fftsize))
- (fdr (make-float-vector N)) ; buffer for real fft data
- (fdi (make-float-vector N)) ; buffer for imaginary fft data
+ (fdr (make-float-vector fftsize)) ; buffer for real fft data
+ (fdi (make-float-vector fftsize)) ; buffer for imaginary fft data
(lastphase (make-float-vector N2)) ;; last phase change
(lastamp (make-float-vector N2)) ;; last sampled amplitude
(lastfreq (make-float-vector N2)) ;; last sampled frequency
(ampinc (make-float-vector N2)) ;; amplitude interpolation increment
(freqinc (make-float-vector N2)) ;; frequency interpolation increments
;; expresses the fundamental in terms of radians per output sample
- (fundamental (/ pi2 N))
+ (fundamental (/ pi2 fftsize))
(output interp) ; count of samples that have been output
;; (nextpct 10.0) ; how often to print out the percentage complete message
(outlen (floor (* time len)))
(out-data (make-float-vector (max len outlen)))
- (in-data (channel->float-vector 0 (* N 2) snd chn))
+ (in-data (channel->float-vector 0 (* fftsize 2) snd chn))
(in-data-beg 0)
- (obank (make-oscil-bank lastfreq (make-float-vector N2 0.0) lastamp)))
+ (obank (make-oscil-bank lastfreq (make-float-vector N2) lastamp)))
(set! window (float-vector-scale! window (/ 2.0 (* 0.54 fftsize)))) ;den = hamming window integrated
(do ((i 0 (+ i 1)))
((>= i outlen))
(when (>= output interp) ;; if all the samples have been output then do the next frame
- (let ((buffix (modulo filptr N)))
+ (let ((buffix (modulo filptr fftsize)))
; buffix is the index into the input buffer
; it wraps around circularly as time increases in the input
(set! output 0) ; reset the output sample counter
@@ -287,23 +284,23 @@
(float-vector-add! lastamp fdr)
(float-vector-add! lastfreq fdi)
(do ((k 0 (+ k 1)))
- ((= k N))
+ ((= k fftsize))
;; apply the window and then stuff into the input array
(set! (fdr buffix) (* (window k) (in-data (- filptr in-data-beg))))
(set! filptr (+ 1 filptr))
;; increment the buffer index with wrap around
(set! buffix (+ 1 buffix))
- (if (>= buffix N) (set! buffix 0)))
+ (if (>= buffix fftsize) (set! buffix 0)))
;; rewind the file for the next hop
- (set! filptr (- (+ filptr D) N))
- (if (> filptr (+ in-data-beg N))
+ (set! filptr (- (+ filptr D) fftsize))
+ (if (> filptr (+ in-data-beg fftsize))
(begin
(set! in-data-beg filptr)
- (set! in-data (channel->float-vector in-data-beg (* N 2) snd chn))))
+ (set! in-data (channel->float-vector in-data-beg (* fftsize 2) snd chn))))
;; no imaginary component input so zero out fdi
(fill! fdi 0.0)
;; compute the fft
- (mus-fft fdr fdi N 1)
+ (mus-fft fdr fdi fftsize 1)
;; now convert into magnitude and interpolated frequency
(do ((k 0 (+ k 1)))
((= k N2))
@@ -325,10 +322,7 @@
(if (< phasediff (- pi)) (do () ((>= phasediff (- pi))) (set! phasediff (+ phasediff pi2))))))
;; current frequency stored in fdi
;; scale by the pitch transposition
- (set! (fdi k)
- (* pitch (+ (/ (* phasediff sr) (* D sr))
- (* k fundamental)
- poffset)))
+ (set! (fdi k) (* pitch (+ (/ phasediff D) (* k fundamental) poffset)))
;; resynthesis gating
(if (< (fdr k) syngate) (set! (fdr k) 0.0))
;; take (lastamp k) and count up to (fdr k)
diff --git a/r7rs.scm b/r7rs.scm
index 620a673..db9952c 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -32,7 +32,7 @@
(k start (+ k 1)))
((= k len) dest)
(set! (dest i) (src k)))
- (do ((i (+ at (- len start 1)) (- i 1))
+ (do ((i (- (+ at len) start 1) (- i 1))
(k (- len 1) (- k 1)))
((< k start) dest)
(set! (dest i) (src k))))))
@@ -94,17 +94,17 @@
(define (port? p) (or (input-port? p) (output-port? p)))
(define binary-port? port?)
(define textual-port? port?)
-(define (close-port p) (if (input-port? p) (close-input-port p) (close-output-port p)))
+(define (close-port p) ((if (input-port? p) close-input-port close-output-port) p))
(define open-binary-input-file open-input-file)
(define open-binary-output-file open-output-file)
-(define (call-with-port port proc)
- ((if (input-port? port) call-with-input-file call-with-output-file) port proc))
+(define (call-with-port port proc) ((if (input-port? port) call-with-input-file call-with-output-file) port proc))
(define (bytevector-u8-ref b k) (b k))
(define (bytevector-u8-set! b k c) (set! (b k) c))
+(define bytevector-u8 (dilambda (lambda (b k) (b k)) (lambda (b k c) (set! (b k) c))))
(define bytevector-length length)
-(define (bytevector-copy . args) (->byte-vector (apply string-copy args)))
+(define (bytevector-copy . args) (->byte-vector (apply r7rs-string-copy args)))
(define (bytevector-append . args) (->byte-vector (apply string-append args)))
(define write-bytevector write-string)
(define* (read-bytevector! bv port (start 0) end)
@@ -382,7 +382,11 @@
(cons 'current-second g_time)))
-(define get-environment-variable (*libc* 'getenv))
+(define (get-environment-variable x)
+ (let ((val ((*libc* 'getenv) x)))
+ (and (string? val)
+ (> (length val) 0)
+ val)))
(define get-environment-variables (*libc* 'getenvs))
(define (r7rs-file-exists? arg) (= ((*libc* 'access) arg (*libc* 'F_OK)) 0))
(define r7rs-delete-file (*libc* 'unlink))
@@ -391,7 +395,7 @@
(define (cpu-architecture) (cadr ((*libc* 'uname))))
(define (machine-name) (caddr ((*libc* 'uname))))
(define (os-version) (string-append (list-ref ((*libc* 'uname)) 3) " " (list-ref ((*libc* 'uname)) 4)))
-(define (implementation-name) "s7")
+(define (implementation-name) (copy "s7"))
(define (implementation-version) (substring (s7-version) 3 7))
;; command-line is problematic: s7 has no access to the caller's "main" function, and
diff --git a/repl.scm b/repl.scm
index 2c72316..b50315c 100644
--- a/repl.scm
+++ b/repl.scm
@@ -228,41 +228,47 @@
;; so, locally redefine these three to use the repl top-level while we're in the repl.
;; in addition, for each of these, we need to report missing close parens and so on
- (define (repl-hooks)
- (set! (hook-functions *missing-close-paren-hook*) (cons badexpr old-badexpr-hook))
- (set! (hook-functions *unbound-variable-hook*) (cons shell? old-unbound-var-hook)))
+ (let ((repl-hooks
+ (lambda ()
+ (set! (hook-functions *missing-close-paren-hook*) (cons badexpr old-badexpr-hook))
+ (set! (hook-functions *unbound-variable-hook*) (cons shell? old-unbound-var-hook))))
- (define (original-hooks)
- (set! unbound-case #f)
- (set! (hook-functions *missing-close-paren-hook*) old-badexpr-hook)
- (set! (hook-functions *unbound-variable-hook*) old-unbound-var-hook))
+ (original-hooks
+ (lambda ()
+ (set! unbound-case #f)
+ (set! (hook-functions *missing-close-paren-hook*) old-badexpr-hook)
+ (set! (hook-functions *unbound-variable-hook*) old-unbound-var-hook))))
- (define new-load (let ((documentation "this is the repl's load replacement; its default is to use the repl's top-level-let.")
- (signature '(values string? let?)))
- (lambda* (file (e (*repl* 'top-level-let)))
- (dynamic-wind original-hooks (lambda () (load file e)) repl-hooks))))
-
- (define new-eval (let ((documentation "this is the repl's eval replacement; its default is to use the repl's top-level-let.")
- (signature '(values list? let?)))
- (lambda* (form (e (*repl* 'top-level-let)))
- (dynamic-wind original-hooks (lambda () (eval form e)) repl-hooks))))
-
- (define new-eval-string (let ((documentation "this is the repl's eval-string replacement; its default is to use the repl's top-level-let.")
- (signature '(values string? let?)))
- (lambda* (str (e (*repl* 'top-level-let)))
- (dynamic-wind original-hooks (lambda () (eval-string str e)) repl-hooks))))
- (dynamic-wind
- (lambda ()
- (repl-hooks)
- (set! eval new-eval)
- (set! eval-string new-eval-string)
- (set! load new-load))
- body
- (lambda ()
- (set! eval old-eval)
- (set! eval-string old-eval-string)
- (set! load old-load)
- (original-hooks)))))
+ (let ((new-load
+ (let ((documentation "this is the repl's load replacement; its default is to use the repl's top-level-let.")
+ (signature '(values string? let?)))
+ (lambda* (file (e (*repl* 'top-level-let)))
+ (dynamic-wind original-hooks (lambda () (load file e)) repl-hooks))))
+
+ (new-eval
+ (let ((documentation "this is the repl's eval replacement; its default is to use the repl's top-level-let.")
+ (signature '(values list? let?)))
+ (lambda* (form (e (*repl* 'top-level-let)))
+ (dynamic-wind original-hooks (lambda () (eval form e)) repl-hooks))))
+
+ (new-eval-string
+ (let ((documentation "this is the repl's eval-string replacement; its default is to use the repl's top-level-let.")
+ (signature '(values string? let?)))
+ (lambda* (str (e (*repl* 'top-level-let)))
+ (dynamic-wind original-hooks (lambda () (eval-string str e)) repl-hooks)))))
+
+ (dynamic-wind
+ (lambda ()
+ (repl-hooks)
+ (set! eval new-eval)
+ (set! eval-string new-eval-string)
+ (set! load new-load))
+ body
+ (lambda ()
+ (set! eval old-eval)
+ (set! eval-string old-eval-string)
+ (set! load old-load)
+ (original-hooks)))))))
;; -------- match parens --------
@@ -389,13 +395,13 @@
(x 0))
(do ((b (read terminal-fd cc 1) (read terminal-fd cc 1)))
((not (char-numeric? (c 0))))
- (set! y (+ (* 10 y) (- (char->integer (c 0)) (char->integer #\0)))))
+ (set! y (- (+ (* 10 y) (char->integer (c 0))) (char->integer #\0))))
(and (char=? (c 0) #\;)
(do ((b (read terminal-fd cc 1) (read terminal-fd cc 1)))
((not (char-numeric? (c 0)))
(and (char=? (c 0) #\R)
(cons x y)))
- (set! x (+ (* 10 x) (- (char->integer (c 0)) (char->integer #\0))))))))))
+ (set! x (- (+ (* 10 x) (char->integer (c 0))) (char->integer #\0)))))))))
(define (cursor-bounds)
(let ((coords (cursor-coords)))
@@ -433,11 +439,11 @@
(format #f "~C[1m~A~C[0m" #\escape text #\escape))
;; if a line wraps, it will confuse the redisplay/cursor positioning code. so truncate the display
- (let ((line-len (+ (- end start) 1 prompt-length)))
+ (let ((line-len (- (+ end prompt-length 1) start)))
(if (>= line-len last-col)
(set! end (- (+ end line-len) last-col))))
- (if (and red-par-pos
+ (if (and (integer? red-par-pos)
(<= start red-par-pos)
(< red-par-pos end))
(string-append
@@ -463,7 +469,7 @@
(do ((i 0 (+ i 1)))
((or (= i len)
(= i cursor-pos))
- (move-cursor (+ prompt-row row) (+ prompt-col (- cursor-pos start))))
+ (move-cursor (+ prompt-row row) (- (+ prompt-col cursor-pos) start)))
(when (char=? (cur-line i) #\newline)
(set! row (+ row 1))
(set! start (+ i 1))))))
@@ -605,14 +611,6 @@
(char=? (cur-line i) #\newline))
(if (zero? i) 0 (+ i 1))))))
- (define (count-newlines line)
- (let ((len (length line))
- (newlines 0))
- (do ((i 0 (+ i 1)))
- ((= i len) newlines)
- (if (char=? (cur-line i) #\newline)
- (set! newlines (+ newlines 1))))))
-
(define (append-newline)
(set! cur-line (string-append cur-line (string #\space #\newline)))
(set! cursor-pos (length cur-line))
@@ -847,9 +845,8 @@
i))))
(set! completion (if (< loc 0)
(symbol-completion cur-line)
- (if (char=? (cur-line loc) #\")
- (filename-completion (substring cur-line (+ loc 1)))
- (symbol-completion (substring cur-line (+ loc 1))))))
+ ((if (char=? (cur-line loc) #\") filename-completion symbol-completion)
+ (substring cur-line (+ loc 1)))))
(when (and completion
(> (length completion) (- end loc 1)))
(save-line)
@@ -948,6 +945,13 @@
;; Meta key is a problem on the Mac, so I'll package these for easier disposal
(define (fixup-new-line)
+ (define (count-newlines line)
+ (let ((len (length line))
+ (newlines 0))
+ (do ((i 0 (+ i 1)))
+ ((= i len) newlines)
+ (if (char=? (cur-line i) #\newline)
+ (set! newlines (+ newlines 1))))))
(set! cursor-pos (length cur-line))
(let ((newlines (count-newlines cur-line)))
(when (< last-row (+ prompt-row newlines))
diff --git a/rgb.scm b/rgb.scm
index cf9816e..c789743 100644
--- a/rgb.scm
+++ b/rgb.scm
@@ -3,666 +3,661 @@
(provide 'snd-rgb.scm)
(define *rgb*
- (let ()
-
-;; tan -> tawny 24-Aug-01
-
-(define snow (make-color 1.00 0.98 0.98))
-(define ghost-white (make-color 0.97 0.97 1.00))
-(define white-smoke (make-color 0.96 0.96 0.96))
-(define gainsboro (make-color 0.86 0.86 0.86))
-(define floral-white (make-color 1.00 0.98 0.94))
-(define old-lace (make-color 0.99 0.96 0.90))
-(define linen (make-color 0.98 0.94 0.90))
-(define antique-white (make-color 0.98 0.92 0.84))
-(define papaya-whip (make-color 1.00 0.93 0.83))
-(define blanched-almond (make-color 1.00 0.92 0.80))
-(define bisque (make-color 1.00 0.89 0.77))
-(define peach-puff (make-color 1.00 0.85 0.72))
-(define navajo-white (make-color 1.00 0.87 0.68))
-(define moccasin (make-color 1.00 0.89 0.71))
-(define cornsilk (make-color 1.00 0.97 0.86))
-(define ivory (make-color 1.00 1.00 0.94))
-(define lemon-chiffon (make-color 1.00 0.98 0.80))
-(define seashell (make-color 1.00 0.96 0.93))
-(define honeydew (make-color 0.94 1.00 0.94))
-(define mint-cream (make-color 0.96 1.00 0.98))
-(define azure (make-color 0.94 1.00 1.00))
-(define alice-blue (make-color 0.94 0.97 1.00))
-(define lavender (make-color 0.90 0.90 0.98))
-(define lavender-blush (make-color 1.00 0.94 0.96))
-(define misty-rose (make-color 1.00 0.89 0.88))
-(define white (make-color 1.00 1.00 1.00))
-(define black (make-color 0.00 0.00 0.00))
-(define dark-slate-gray (make-color 0.18 0.31 0.31))
-(define dark-slate-grey (make-color 0.18 0.31 0.31))
-(define dim-gray (make-color 0.41 0.41 0.41))
-(define dim-grey (make-color 0.41 0.41 0.41))
-(define slate-gray (make-color 0.44 0.50 0.56))
-(define slate-grey (make-color 0.44 0.50 0.56))
-(define light-slate-gray (make-color 0.46 0.53 0.60))
-(define light-slate-grey (make-color 0.46 0.53 0.60))
-(define gray (make-color 0.74 0.74 0.74))
-(define grey (make-color 0.74 0.74 0.74))
-(define light-grey (make-color 0.82 0.82 0.82))
-(define light-gray (make-color 0.82 0.82 0.82))
-(define midnight-blue (make-color 0.10 0.10 0.44))
-(define navy (make-color 0.00 0.00 0.50))
-(define navy-blue (make-color 0.00 0.00 0.50))
-(define cornflower-blue (make-color 0.39 0.58 0.93))
-(define dark-slate-blue (make-color 0.28 0.24 0.54))
-(define slate-blue (make-color 0.41 0.35 0.80))
-(define medium-slate-blue (make-color 0.48 0.41 0.93))
-(define light-slate-blue (make-color 0.52 0.44 1.00))
-(define medium-blue (make-color 0.00 0.00 0.80))
-(define royal-blue (make-color 0.25 0.41 0.88))
-(define blue (make-color 0.00 0.00 1.00))
-(define dodger-blue (make-color 0.12 0.56 1.00))
-(define deep-sky-blue (make-color 0.00 0.75 1.00))
-(define sky-blue (make-color 0.53 0.80 0.92))
-(define light-sky-blue (make-color 0.53 0.80 0.98))
-(define steel-blue (make-color 0.27 0.51 0.70))
-(define light-steel-blue (make-color 0.69 0.77 0.87))
-(define light-blue (make-color 0.68 0.84 0.90))
-(define powder-blue (make-color 0.69 0.87 0.90))
-(define pale-turquoise (make-color 0.68 0.93 0.93))
-(define dark-turquoise (make-color 0.00 0.80 0.82))
-(define medium-turquoise (make-color 0.28 0.82 0.80))
-(define turquoise (make-color 0.25 0.87 0.81))
-(define cyan (make-color 0.00 1.00 1.00))
-(define light-cyan (make-color 0.87 1.00 1.00))
-(define cadet-blue (make-color 0.37 0.62 0.62))
-(define medium-aquamarine (make-color 0.40 0.80 0.66))
-(define aquamarine (make-color 0.50 1.00 0.83))
-(define dark-green (make-color 0.00 0.39 0.00))
-(define dark-olive-green (make-color 0.33 0.42 0.18))
-(define dark-sea-green (make-color 0.56 0.73 0.56))
-(define sea-green (make-color 0.18 0.54 0.34))
-(define medium-sea-green (make-color 0.23 0.70 0.44))
-(define light-sea-green (make-color 0.12 0.70 0.66))
-(define pale-green (make-color 0.59 0.98 0.59))
-(define spring-green (make-color 0.00 1.00 0.50))
-(define lawn-green (make-color 0.48 0.98 0.00))
-(define green (make-color 0.00 1.00 0.00))
-(define chartreuse (make-color 0.50 1.00 0.00))
-(define medium-spring-green (make-color 0.00 0.98 0.60))
-(define green-yellow (make-color 0.68 1.00 0.18))
-(define lime-green (make-color 0.20 0.80 0.20))
-(define yellow-green (make-color 0.60 0.80 0.20))
-(define forest-green (make-color 0.13 0.54 0.13))
-(define olive-drab (make-color 0.42 0.55 0.14))
-(define dark-khaki (make-color 0.74 0.71 0.42))
-(define khaki (make-color 0.94 0.90 0.55))
-(define pale-goldenrod (make-color 0.93 0.91 0.66))
-(define light-goldenrod-yellow (make-color 0.98 0.98 0.82))
-(define light-yellow (make-color 1.00 1.00 0.87))
-(define yellow (make-color 1.00 1.00 0.00))
-(define gold (make-color 1.00 0.84 0.00))
-(define light-goldenrod (make-color 0.93 0.86 0.51))
-(define goldenrod (make-color 0.85 0.64 0.12))
-(define dark-goldenrod (make-color 0.72 0.52 0.04))
-(define rosy-brown (make-color 0.73 0.56 0.56))
-(define indian-red (make-color 0.80 0.36 0.36))
-(define saddle-brown (make-color 0.54 0.27 0.07))
-(define sienna (make-color 0.62 0.32 0.18))
-(define peru (make-color 0.80 0.52 0.25))
-(define burlywood (make-color 0.87 0.72 0.53))
-(define beige (make-color 0.96 0.96 0.86))
-(define wheat (make-color 0.96 0.87 0.70))
-(define sandy-brown (make-color 0.95 0.64 0.37))
-(define tawny (make-color 0.82 0.70 0.55)) ; tan collides with Scheme built-in -- tawny suggested by Dave Phillips
-(define chocolate (make-color 0.82 0.41 0.12))
-(define firebrick (make-color 0.70 0.13 0.13))
-(define brown (make-color 0.64 0.16 0.16))
-(define dark-salmon (make-color 0.91 0.59 0.48))
-(define salmon (make-color 0.98 0.50 0.45))
-(define light-salmon (make-color 1.00 0.62 0.48))
-(define orange (make-color 1.00 0.64 0.00))
-(define dark-orange (make-color 1.00 0.55 0.00))
-(define coral (make-color 1.00 0.50 0.31))
-(define light-coral (make-color 0.94 0.50 0.50))
-(define tomato (make-color 1.00 0.39 0.28))
-(define orange-red (make-color 1.00 0.27 0.00))
-(define red (make-color 1.00 0.00 0.00))
-(define hot-pink (make-color 1.00 0.41 0.70))
-(define deep-pink (make-color 1.00 0.08 0.57))
-(define pink (make-color 1.00 0.75 0.79))
-(define light-pink (make-color 1.00 0.71 0.75))
-(define pale-violet-red (make-color 0.86 0.44 0.57))
-(define maroon (make-color 0.69 0.19 0.37))
-(define medium-violet-red (make-color 0.78 0.08 0.52))
-(define violet-red (make-color 0.81 0.12 0.56))
-(define magenta (make-color 1.00 0.00 1.00))
-(define violet (make-color 0.93 0.51 0.93))
-(define plum (make-color 0.86 0.62 0.86))
-(define orchid (make-color 0.85 0.44 0.84))
-(define medium-orchid (make-color 0.73 0.33 0.82))
-(define dark-orchid (make-color 0.60 0.20 0.80))
-(define dark-violet (make-color 0.58 0.00 0.82))
-(define blue-violet (make-color 0.54 0.17 0.88))
-(define purple (make-color 0.62 0.12 0.94))
-(define medium-purple (make-color 0.57 0.44 0.86))
-(define thistle (make-color 0.84 0.75 0.84))
-(define snow1 (make-color 1.00 0.98 0.98))
-(define snow2 (make-color 0.93 0.91 0.91))
-(define snow3 (make-color 0.80 0.79 0.79))
-(define snow4 (make-color 0.54 0.54 0.54))
-(define seashell1 (make-color 1.00 0.96 0.93))
-(define seashell2 (make-color 0.93 0.89 0.87))
-(define seashell3 (make-color 0.80 0.77 0.75))
-(define seashell4 (make-color 0.54 0.52 0.51))
-(define antiquewhite1 (make-color 1.00 0.93 0.86))
-(define antiquewhite2 (make-color 0.93 0.87 0.80))
-(define antiquewhite3 (make-color 0.80 0.75 0.69))
-(define antiquewhite4 (make-color 0.54 0.51 0.47))
-(define bisque1 (make-color 1.00 0.89 0.77))
-(define bisque2 (make-color 0.93 0.83 0.71))
-(define bisque3 (make-color 0.80 0.71 0.62))
-(define bisque4 (make-color 0.54 0.49 0.42))
-(define peachpuff1 (make-color 1.00 0.85 0.72))
-(define peachpuff2 (make-color 0.93 0.79 0.68))
-(define peachpuff3 (make-color 0.80 0.68 0.58))
-(define peachpuff4 (make-color 0.54 0.46 0.39))
-(define navajowhite1 (make-color 1.00 0.87 0.68))
-(define navajowhite2 (make-color 0.93 0.81 0.63))
-(define navajowhite3 (make-color 0.80 0.70 0.54))
-(define navajowhite4 (make-color 0.54 0.47 0.37))
-(define lemonchiffon1 (make-color 1.00 0.98 0.80))
-(define lemonchiffon2 (make-color 0.93 0.91 0.75))
-(define lemonchiffon3 (make-color 0.80 0.79 0.64))
-(define lemonchiffon4 (make-color 0.54 0.54 0.44))
-(define cornsilk1 (make-color 1.00 0.97 0.86))
-(define cornsilk2 (make-color 0.93 0.91 0.80))
-(define cornsilk3 (make-color 0.80 0.78 0.69))
-(define cornsilk4 (make-color 0.54 0.53 0.47))
-(define ivory1 (make-color 1.00 1.00 0.94))
-(define ivory2 (make-color 0.93 0.93 0.87))
-(define ivory3 (make-color 0.80 0.80 0.75))
-(define ivory4 (make-color 0.54 0.54 0.51))
-(define honeydew1 (make-color 0.94 1.00 0.94))
-(define honeydew2 (make-color 0.87 0.93 0.87))
-(define honeydew3 (make-color 0.75 0.80 0.75))
-(define honeydew4 (make-color 0.51 0.54 0.51))
-(define lavenderblush1 (make-color 1.00 0.94 0.96))
-(define lavenderblush2 (make-color 0.93 0.87 0.89))
-(define lavenderblush3 (make-color 0.80 0.75 0.77))
-(define lavenderblush4 (make-color 0.54 0.51 0.52))
-(define mistyrose1 (make-color 1.00 0.89 0.88))
-(define mistyrose2 (make-color 0.93 0.83 0.82))
-(define mistyrose3 (make-color 0.80 0.71 0.71))
-(define mistyrose4 (make-color 0.54 0.49 0.48))
-(define azure1 (make-color 0.94 1.00 1.00))
-(define azure2 (make-color 0.87 0.93 0.93))
-(define azure3 (make-color 0.75 0.80 0.80))
-(define azure4 (make-color 0.51 0.54 0.54))
-(define slateblue1 (make-color 0.51 0.43 1.00))
-(define slateblue2 (make-color 0.48 0.40 0.93))
-(define slateblue3 (make-color 0.41 0.35 0.80))
-(define slateblue4 (make-color 0.28 0.23 0.54))
-(define royalblue1 (make-color 0.28 0.46 1.00))
-(define royalblue2 (make-color 0.26 0.43 0.93))
-(define royalblue3 (make-color 0.23 0.37 0.80))
-(define royalblue4 (make-color 0.15 0.25 0.54))
-(define blue1 (make-color 0.00 0.00 1.00))
-(define blue2 (make-color 0.00 0.00 0.93))
-(define blue3 (make-color 0.00 0.00 0.80))
-(define blue4 (make-color 0.00 0.00 0.54))
-(define dodgerblue1 (make-color 0.12 0.56 1.00))
-(define dodgerblue2 (make-color 0.11 0.52 0.93))
-(define dodgerblue3 (make-color 0.09 0.45 0.80))
-(define dodgerblue4 (make-color 0.06 0.30 0.54))
-(define steelblue1 (make-color 0.39 0.72 1.00))
-(define steelblue2 (make-color 0.36 0.67 0.93))
-(define steelblue3 (make-color 0.31 0.58 0.80))
-(define steelblue4 (make-color 0.21 0.39 0.54))
-(define deepskyblue1 (make-color 0.00 0.75 1.00))
-(define deepskyblue2 (make-color 0.00 0.70 0.93))
-(define deepskyblue3 (make-color 0.00 0.60 0.80))
-(define deepskyblue4 (make-color 0.00 0.41 0.54))
-(define skyblue1 (make-color 0.53 0.80 1.00))
-(define skyblue2 (make-color 0.49 0.75 0.93))
-(define skyblue3 (make-color 0.42 0.65 0.80))
-(define skyblue4 (make-color 0.29 0.44 0.54))
-(define lightskyblue1 (make-color 0.69 0.88 1.00))
-(define lightskyblue2 (make-color 0.64 0.82 0.93))
-(define lightskyblue3 (make-color 0.55 0.71 0.80))
-(define lightskyblue4 (make-color 0.37 0.48 0.54))
-(define slategray1 (make-color 0.77 0.88 1.00))
-(define slategray2 (make-color 0.72 0.82 0.93))
-(define slategray3 (make-color 0.62 0.71 0.80))
-(define slategray4 (make-color 0.42 0.48 0.54))
-(define lightsteelblue1 (make-color 0.79 0.88 1.00))
-(define lightsteelblue2 (make-color 0.73 0.82 0.93))
-(define lightsteelblue3 (make-color 0.63 0.71 0.80))
-(define lightsteelblue4 (make-color 0.43 0.48 0.54))
-(define lightblue1 (make-color 0.75 0.93 1.00))
-(define lightblue2 (make-color 0.70 0.87 0.93))
-(define lightblue3 (make-color 0.60 0.75 0.80))
-(define lightblue4 (make-color 0.41 0.51 0.54))
-(define lightcyan1 (make-color 0.87 1.00 1.00))
-(define lightcyan2 (make-color 0.82 0.93 0.93))
-(define lightcyan3 (make-color 0.70 0.80 0.80))
-(define lightcyan4 (make-color 0.48 0.54 0.54))
-(define paleturquoise1 (make-color 0.73 1.00 1.00))
-(define paleturquoise2 (make-color 0.68 0.93 0.93))
-(define paleturquoise3 (make-color 0.59 0.80 0.80))
-(define paleturquoise4 (make-color 0.40 0.54 0.54))
-(define cadetblue1 (make-color 0.59 0.96 1.00))
-(define cadetblue2 (make-color 0.55 0.89 0.93))
-(define cadetblue3 (make-color 0.48 0.77 0.80))
-(define cadetblue4 (make-color 0.32 0.52 0.54))
-(define turquoise1 (make-color 0.00 0.96 1.00))
-(define turquoise2 (make-color 0.00 0.89 0.93))
-(define turquoise3 (make-color 0.00 0.77 0.80))
-(define turquoise4 (make-color 0.00 0.52 0.54))
-(define cyan1 (make-color 0.00 1.00 1.00))
-(define cyan2 (make-color 0.00 0.93 0.93))
-(define cyan3 (make-color 0.00 0.80 0.80))
-(define cyan4 (make-color 0.00 0.54 0.54))
-(define darkslategray1 (make-color 0.59 1.00 1.00))
-(define darkslategray2 (make-color 0.55 0.93 0.93))
-(define darkslategray3 (make-color 0.47 0.80 0.80))
-(define darkslategray4 (make-color 0.32 0.54 0.54))
-(define aquamarine1 (make-color 0.50 1.00 0.83))
-(define aquamarine2 (make-color 0.46 0.93 0.77))
-(define aquamarine3 (make-color 0.40 0.80 0.66))
-(define aquamarine4 (make-color 0.27 0.54 0.45))
-(define darkseagreen1 (make-color 0.75 1.00 0.75))
-(define darkseagreen2 (make-color 0.70 0.93 0.70))
-(define darkseagreen3 (make-color 0.61 0.80 0.61))
-(define darkseagreen4 (make-color 0.41 0.54 0.41))
-(define seagreen1 (make-color 0.33 1.00 0.62))
-(define seagreen2 (make-color 0.30 0.93 0.58))
-(define seagreen3 (make-color 0.26 0.80 0.50))
-(define seagreen4 (make-color 0.18 0.54 0.34))
-(define palegreen1 (make-color 0.60 1.00 0.60))
-(define palegreen2 (make-color 0.56 0.93 0.56))
-(define palegreen3 (make-color 0.48 0.80 0.48))
-(define palegreen4 (make-color 0.33 0.54 0.33))
-(define springgreen1 (make-color 0.00 1.00 0.50))
-(define springgreen2 (make-color 0.00 0.93 0.46))
-(define springgreen3 (make-color 0.00 0.80 0.40))
-(define springgreen4 (make-color 0.00 0.54 0.27))
-(define green1 (make-color 0.00 1.00 0.00))
-(define green2 (make-color 0.00 0.93 0.00))
-(define green3 (make-color 0.00 0.80 0.00))
-(define green4 (make-color 0.00 0.54 0.00))
-(define chartreuse1 (make-color 0.50 1.00 0.00))
-(define chartreuse2 (make-color 0.46 0.93 0.00))
-(define chartreuse3 (make-color 0.40 0.80 0.00))
-(define chartreuse4 (make-color 0.27 0.54 0.00))
-(define olivedrab1 (make-color 0.75 1.00 0.24))
-(define olivedrab2 (make-color 0.70 0.93 0.23))
-(define olivedrab3 (make-color 0.60 0.80 0.20))
-(define olivedrab4 (make-color 0.41 0.54 0.13))
-(define darkolivegreen1 (make-color 0.79 1.00 0.44))
-(define darkolivegreen2 (make-color 0.73 0.93 0.41))
-(define darkolivegreen3 (make-color 0.63 0.80 0.35))
-(define darkolivegreen4 (make-color 0.43 0.54 0.24))
-(define khaki1 (make-color 1.00 0.96 0.56))
-(define khaki2 (make-color 0.93 0.90 0.52))
-(define khaki3 (make-color 0.80 0.77 0.45))
-(define khaki4 (make-color 0.54 0.52 0.30))
-(define lightgoldenrod1 (make-color 1.00 0.92 0.54))
-(define lightgoldenrod2 (make-color 0.93 0.86 0.51))
-(define lightgoldenrod3 (make-color 0.80 0.74 0.44))
-(define lightgoldenrod4 (make-color 0.54 0.50 0.30))
-(define lightyellow1 (make-color 1.00 1.00 0.87))
-(define lightyellow2 (make-color 0.93 0.93 0.82))
-(define lightyellow3 (make-color 0.80 0.80 0.70))
-(define lightyellow4 (make-color 0.54 0.54 0.48))
-(define yellow1 (make-color 1.00 1.00 0.00))
-(define yellow2 (make-color 0.93 0.93 0.00))
-(define yellow3 (make-color 0.80 0.80 0.00))
-(define yellow4 (make-color 0.54 0.54 0.00))
-(define gold1 (make-color 1.00 0.84 0.00))
-(define gold2 (make-color 0.93 0.79 0.00))
-(define gold3 (make-color 0.80 0.68 0.00))
-(define gold4 (make-color 0.54 0.46 0.00))
-(define goldenrod1 (make-color 1.00 0.75 0.14))
-(define goldenrod2 (make-color 0.93 0.70 0.13))
-(define goldenrod3 (make-color 0.80 0.61 0.11))
-(define goldenrod4 (make-color 0.54 0.41 0.08))
-(define darkgoldenrod1 (make-color 1.00 0.72 0.06))
-(define darkgoldenrod2 (make-color 0.93 0.68 0.05))
-(define darkgoldenrod3 (make-color 0.80 0.58 0.05))
-(define darkgoldenrod4 (make-color 0.54 0.39 0.03))
-(define rosybrown1 (make-color 1.00 0.75 0.75))
-(define rosybrown2 (make-color 0.93 0.70 0.70))
-(define rosybrown3 (make-color 0.80 0.61 0.61))
-(define rosybrown4 (make-color 0.54 0.41 0.41))
-(define indianred1 (make-color 1.00 0.41 0.41))
-(define indianred2 (make-color 0.93 0.39 0.39))
-(define indianred3 (make-color 0.80 0.33 0.33))
-(define indianred4 (make-color 0.54 0.23 0.23))
-(define sienna1 (make-color 1.00 0.51 0.28))
-(define sienna2 (make-color 0.93 0.47 0.26))
-(define sienna3 (make-color 0.80 0.41 0.22))
-(define sienna4 (make-color 0.54 0.28 0.15))
-(define burlywood1 (make-color 1.00 0.82 0.61))
-(define burlywood2 (make-color 0.93 0.77 0.57))
-(define burlywood3 (make-color 0.80 0.66 0.49))
-(define burlywood4 (make-color 0.54 0.45 0.33))
-(define wheat1 (make-color 1.00 0.90 0.73))
-(define wheat2 (make-color 0.93 0.84 0.68))
-(define wheat3 (make-color 0.80 0.73 0.59))
-(define wheat4 (make-color 0.54 0.49 0.40))
-(define tan1 (make-color 1.00 0.64 0.31))
-(define tan2 (make-color 0.93 0.60 0.29))
-(define tan3 (make-color 0.80 0.52 0.25))
-(define tan4 (make-color 0.54 0.35 0.17))
-(define chocolate1 (make-color 1.00 0.50 0.14))
-(define chocolate2 (make-color 0.93 0.46 0.13))
-(define chocolate3 (make-color 0.80 0.40 0.11))
-(define chocolate4 (make-color 0.54 0.27 0.07))
-(define firebrick1 (make-color 1.00 0.19 0.19))
-(define firebrick2 (make-color 0.93 0.17 0.17))
-(define firebrick3 (make-color 0.80 0.15 0.15))
-(define firebrick4 (make-color 0.54 0.10 0.10))
-(define brown1 (make-color 1.00 0.25 0.25))
-(define brown2 (make-color 0.93 0.23 0.23))
-(define brown3 (make-color 0.80 0.20 0.20))
-(define brown4 (make-color 0.54 0.14 0.14))
-(define salmon1 (make-color 1.00 0.55 0.41))
-(define salmon2 (make-color 0.93 0.51 0.38))
-(define salmon3 (make-color 0.80 0.44 0.33))
-(define salmon4 (make-color 0.54 0.30 0.22))
-(define lightsalmon1 (make-color 1.00 0.62 0.48))
-(define lightsalmon2 (make-color 0.93 0.58 0.45))
-(define lightsalmon3 (make-color 0.80 0.50 0.38))
-(define lightsalmon4 (make-color 0.54 0.34 0.26))
-(define orange1 (make-color 1.00 0.64 0.00))
-(define orange2 (make-color 0.93 0.60 0.00))
-(define orange3 (make-color 0.80 0.52 0.00))
-(define orange4 (make-color 0.54 0.35 0.00))
-(define darkorange1 (make-color 1.00 0.50 0.00))
-(define darkorange2 (make-color 0.93 0.46 0.00))
-(define darkorange3 (make-color 0.80 0.40 0.00))
-(define darkorange4 (make-color 0.54 0.27 0.00))
-(define coral1 (make-color 1.00 0.45 0.34))
-(define coral2 (make-color 0.93 0.41 0.31))
-(define coral3 (make-color 0.80 0.36 0.27))
-(define coral4 (make-color 0.54 0.24 0.18))
-(define tomato1 (make-color 1.00 0.39 0.28))
-(define tomato2 (make-color 0.93 0.36 0.26))
-(define tomato3 (make-color 0.80 0.31 0.22))
-(define tomato4 (make-color 0.54 0.21 0.15))
-(define orangered1 (make-color 1.00 0.27 0.00))
-(define orangered2 (make-color 0.93 0.25 0.00))
-(define orangered3 (make-color 0.80 0.21 0.00))
-(define orangered4 (make-color 0.54 0.14 0.00))
-(define red1 (make-color 1.00 0.00 0.00))
-(define red2 (make-color 0.93 0.00 0.00))
-(define red3 (make-color 0.80 0.00 0.00))
-(define red4 (make-color 0.54 0.00 0.00))
-(define deeppink1 (make-color 1.00 0.08 0.57))
-(define deeppink2 (make-color 0.93 0.07 0.54))
-(define deeppink3 (make-color 0.80 0.06 0.46))
-(define deeppink4 (make-color 0.54 0.04 0.31))
-(define hotpink1 (make-color 1.00 0.43 0.70))
-(define hotpink2 (make-color 0.93 0.41 0.65))
-(define hotpink3 (make-color 0.80 0.37 0.56))
-(define hotpink4 (make-color 0.54 0.23 0.38))
-(define pink1 (make-color 1.00 0.71 0.77))
-(define pink2 (make-color 0.93 0.66 0.72))
-(define pink3 (make-color 0.80 0.57 0.62))
-(define pink4 (make-color 0.54 0.39 0.42))
-(define lightpink1 (make-color 1.00 0.68 0.72))
-(define lightpink2 (make-color 0.93 0.63 0.68))
-(define lightpink3 (make-color 0.80 0.55 0.58))
-(define lightpink4 (make-color 0.54 0.37 0.39))
-(define palevioletred1 (make-color 1.00 0.51 0.67))
-(define palevioletred2 (make-color 0.93 0.47 0.62))
-(define palevioletred3 (make-color 0.80 0.41 0.54))
-(define palevioletred4 (make-color 0.54 0.28 0.36))
-(define maroon1 (make-color 1.00 0.20 0.70))
-(define maroon2 (make-color 0.93 0.19 0.65))
-(define maroon3 (make-color 0.80 0.16 0.56))
-(define maroon4 (make-color 0.54 0.11 0.38))
-(define violetred1 (make-color 1.00 0.24 0.59))
-(define violetred2 (make-color 0.93 0.23 0.55))
-(define violetred3 (make-color 0.80 0.20 0.47))
-(define violetred4 (make-color 0.54 0.13 0.32))
-(define magenta1 (make-color 1.00 0.00 1.00))
-(define magenta2 (make-color 0.93 0.00 0.93))
-(define magenta3 (make-color 0.80 0.00 0.80))
-(define magenta4 (make-color 0.54 0.00 0.54))
-(define orchid1 (make-color 1.00 0.51 0.98))
-(define orchid2 (make-color 0.93 0.48 0.91))
-(define orchid3 (make-color 0.80 0.41 0.79))
-(define orchid4 (make-color 0.54 0.28 0.54))
-(define plum1 (make-color 1.00 0.73 1.00))
-(define plum2 (make-color 0.93 0.68 0.93))
-(define plum3 (make-color 0.80 0.59 0.80))
-(define plum4 (make-color 0.54 0.40 0.54))
-(define mediumorchid1 (make-color 0.87 0.40 1.00))
-(define mediumorchid2 (make-color 0.82 0.37 0.93))
-(define mediumorchid3 (make-color 0.70 0.32 0.80))
-(define mediumorchid4 (make-color 0.48 0.21 0.54))
-(define darkorchid1 (make-color 0.75 0.24 1.00))
-(define darkorchid2 (make-color 0.70 0.23 0.93))
-(define darkorchid3 (make-color 0.60 0.20 0.80))
-(define darkorchid4 (make-color 0.41 0.13 0.54))
-(define purple1 (make-color 0.61 0.19 1.00))
-(define purple2 (make-color 0.57 0.17 0.93))
-(define purple3 (make-color 0.49 0.15 0.80))
-(define purple4 (make-color 0.33 0.10 0.54))
-(define mediumpurple1 (make-color 0.67 0.51 1.00))
-(define mediumpurple2 (make-color 0.62 0.47 0.93))
-(define mediumpurple3 (make-color 0.54 0.41 0.80))
-(define mediumpurple4 (make-color 0.36 0.28 0.54))
-(define thistle1 (make-color 1.00 0.88 1.00))
-(define thistle2 (make-color 0.93 0.82 0.93))
-(define thistle3 (make-color 0.80 0.71 0.80))
-(define thistle4 (make-color 0.54 0.48 0.54))
-(define gray0 (make-color 0.00 0.00 0.00))
-(define grey0 (make-color 0.00 0.00 0.00))
-(define gray1 (make-color 0.01 0.01 0.01))
-(define grey1 (make-color 0.01 0.01 0.01))
-(define gray2 (make-color 0.02 0.02 0.02))
-(define grey2 (make-color 0.02 0.02 0.02))
-(define gray3 (make-color 0.03 0.03 0.03))
-(define grey3 (make-color 0.03 0.03 0.03))
-(define gray4 (make-color 0.04 0.04 0.04))
-(define grey4 (make-color 0.04 0.04 0.04))
-(define gray5 (make-color 0.05 0.05 0.05))
-(define grey5 (make-color 0.05 0.05 0.05))
-(define gray6 (make-color 0.06 0.06 0.06))
-(define grey6 (make-color 0.06 0.06 0.06))
-(define gray7 (make-color 0.07 0.07 0.07))
-(define grey7 (make-color 0.07 0.07 0.07))
-(define gray8 (make-color 0.08 0.08 0.08))
-(define grey8 (make-color 0.08 0.08 0.08))
-(define gray9 (make-color 0.09 0.09 0.09))
-(define grey9 (make-color 0.09 0.09 0.09))
-(define gray10 (make-color 0.10 0.10 0.10))
-(define grey10 (make-color 0.10 0.10 0.10))
-(define gray11 (make-color 0.11 0.11 0.11))
-(define grey11 (make-color 0.11 0.11 0.11))
-(define gray12 (make-color 0.12 0.12 0.12))
-(define grey12 (make-color 0.12 0.12 0.12))
-(define gray13 (make-color 0.13 0.13 0.13))
-(define grey13 (make-color 0.13 0.13 0.13))
-(define gray14 (make-color 0.14 0.14 0.14))
-(define grey14 (make-color 0.14 0.14 0.14))
-(define gray15 (make-color 0.15 0.15 0.15))
-(define grey15 (make-color 0.15 0.15 0.15))
-(define gray16 (make-color 0.16 0.16 0.16))
-(define grey16 (make-color 0.16 0.16 0.16))
-(define gray17 (make-color 0.17 0.17 0.17))
-(define grey17 (make-color 0.17 0.17 0.17))
-(define gray18 (make-color 0.18 0.18 0.18))
-(define grey18 (make-color 0.18 0.18 0.18))
-(define gray19 (make-color 0.19 0.19 0.19))
-(define grey19 (make-color 0.19 0.19 0.19))
-(define gray20 (make-color 0.20 0.20 0.20))
-(define grey20 (make-color 0.20 0.20 0.20))
-(define gray21 (make-color 0.21 0.21 0.21))
-(define grey21 (make-color 0.21 0.21 0.21))
-(define gray22 (make-color 0.22 0.22 0.22))
-(define grey22 (make-color 0.22 0.22 0.22))
-(define gray23 (make-color 0.23 0.23 0.23))
-(define grey23 (make-color 0.23 0.23 0.23))
-(define gray24 (make-color 0.24 0.24 0.24))
-(define grey24 (make-color 0.24 0.24 0.24))
-(define gray25 (make-color 0.25 0.25 0.25))
-(define grey25 (make-color 0.25 0.25 0.25))
-(define gray26 (make-color 0.26 0.26 0.26))
-(define grey26 (make-color 0.26 0.26 0.26))
-(define gray27 (make-color 0.27 0.27 0.27))
-(define grey27 (make-color 0.27 0.27 0.27))
-(define gray28 (make-color 0.28 0.28 0.28))
-(define grey28 (make-color 0.28 0.28 0.28))
-(define gray29 (make-color 0.29 0.29 0.29))
-(define grey29 (make-color 0.29 0.29 0.29))
-(define gray30 (make-color 0.30 0.30 0.30))
-(define grey30 (make-color 0.30 0.30 0.30))
-(define gray31 (make-color 0.31 0.31 0.31))
-(define grey31 (make-color 0.31 0.31 0.31))
-(define gray32 (make-color 0.32 0.32 0.32))
-(define grey32 (make-color 0.32 0.32 0.32))
-(define gray33 (make-color 0.33 0.33 0.33))
-(define grey33 (make-color 0.33 0.33 0.33))
-(define gray34 (make-color 0.34 0.34 0.34))
-(define grey34 (make-color 0.34 0.34 0.34))
-(define gray35 (make-color 0.35 0.35 0.35))
-(define grey35 (make-color 0.35 0.35 0.35))
-(define gray36 (make-color 0.36 0.36 0.36))
-(define grey36 (make-color 0.36 0.36 0.36))
-(define gray37 (make-color 0.37 0.37 0.37))
-(define grey37 (make-color 0.37 0.37 0.37))
-(define gray38 (make-color 0.38 0.38 0.38))
-(define grey38 (make-color 0.38 0.38 0.38))
-(define gray39 (make-color 0.39 0.39 0.39))
-(define grey39 (make-color 0.39 0.39 0.39))
-(define gray40 (make-color 0.40 0.40 0.40))
-(define grey40 (make-color 0.40 0.40 0.40))
-(define gray41 (make-color 0.41 0.41 0.41))
-(define grey41 (make-color 0.41 0.41 0.41))
-(define gray42 (make-color 0.42 0.42 0.42))
-(define grey42 (make-color 0.42 0.42 0.42))
-(define gray43 (make-color 0.43 0.43 0.43))
-(define grey43 (make-color 0.43 0.43 0.43))
-(define gray44 (make-color 0.44 0.44 0.44))
-(define grey44 (make-color 0.44 0.44 0.44))
-(define gray45 (make-color 0.45 0.45 0.45))
-(define grey45 (make-color 0.45 0.45 0.45))
-(define gray46 (make-color 0.46 0.46 0.46))
-(define grey46 (make-color 0.46 0.46 0.46))
-(define gray47 (make-color 0.47 0.47 0.47))
-(define grey47 (make-color 0.47 0.47 0.47))
-(define gray48 (make-color 0.48 0.48 0.48))
-(define grey48 (make-color 0.48 0.48 0.48))
-(define gray49 (make-color 0.49 0.49 0.49))
-(define grey49 (make-color 0.49 0.49 0.49))
-(define gray50 (make-color 0.50 0.50 0.50))
-(define grey50 (make-color 0.50 0.50 0.50))
-(define gray51 (make-color 0.51 0.51 0.51))
-(define grey51 (make-color 0.51 0.51 0.51))
-(define gray52 (make-color 0.52 0.52 0.52))
-(define grey52 (make-color 0.52 0.52 0.52))
-(define gray53 (make-color 0.53 0.53 0.53))
-(define grey53 (make-color 0.53 0.53 0.53))
-(define gray54 (make-color 0.54 0.54 0.54))
-(define grey54 (make-color 0.54 0.54 0.54))
-(define gray55 (make-color 0.55 0.55 0.55))
-(define grey55 (make-color 0.55 0.55 0.55))
-(define gray56 (make-color 0.56 0.56 0.56))
-(define grey56 (make-color 0.56 0.56 0.56))
-(define gray57 (make-color 0.57 0.57 0.57))
-(define grey57 (make-color 0.57 0.57 0.57))
-(define gray58 (make-color 0.58 0.58 0.58))
-(define grey58 (make-color 0.58 0.58 0.58))
-(define gray59 (make-color 0.59 0.59 0.59))
-(define grey59 (make-color 0.59 0.59 0.59))
-(define gray60 (make-color 0.60 0.60 0.60))
-(define grey60 (make-color 0.60 0.60 0.60))
-(define gray61 (make-color 0.61 0.61 0.61))
-(define grey61 (make-color 0.61 0.61 0.61))
-(define gray62 (make-color 0.62 0.62 0.62))
-(define grey62 (make-color 0.62 0.62 0.62))
-(define gray63 (make-color 0.63 0.63 0.63))
-(define grey63 (make-color 0.63 0.63 0.63))
-(define gray64 (make-color 0.64 0.64 0.64))
-(define grey64 (make-color 0.64 0.64 0.64))
-(define gray65 (make-color 0.65 0.65 0.65))
-(define grey65 (make-color 0.65 0.65 0.65))
-(define gray66 (make-color 0.66 0.66 0.66))
-(define grey66 (make-color 0.66 0.66 0.66))
-(define gray67 (make-color 0.67 0.67 0.67))
-(define grey67 (make-color 0.67 0.67 0.67))
-(define gray68 (make-color 0.68 0.68 0.68))
-(define grey68 (make-color 0.68 0.68 0.68))
-(define gray69 (make-color 0.69 0.69 0.69))
-(define grey69 (make-color 0.69 0.69 0.69))
-(define gray70 (make-color 0.70 0.70 0.70))
-(define grey70 (make-color 0.70 0.70 0.70))
-(define gray71 (make-color 0.71 0.71 0.71))
-(define grey71 (make-color 0.71 0.71 0.71))
-(define gray72 (make-color 0.72 0.72 0.72))
-(define grey72 (make-color 0.72 0.72 0.72))
-(define gray73 (make-color 0.73 0.73 0.73))
-(define grey73 (make-color 0.73 0.73 0.73))
-(define gray74 (make-color 0.74 0.74 0.74))
-(define grey74 (make-color 0.74 0.74 0.74))
-(define gray75 (make-color 0.75 0.75 0.75))
-(define grey75 (make-color 0.75 0.75 0.75))
-(define gray76 (make-color 0.76 0.76 0.76))
-(define grey76 (make-color 0.76 0.76 0.76))
-(define gray77 (make-color 0.77 0.77 0.77))
-(define grey77 (make-color 0.77 0.77 0.77))
-(define gray78 (make-color 0.78 0.78 0.78))
-(define grey78 (make-color 0.78 0.78 0.78))
-(define gray79 (make-color 0.79 0.79 0.79))
-(define grey79 (make-color 0.79 0.79 0.79))
-(define gray80 (make-color 0.80 0.80 0.80))
-(define grey80 (make-color 0.80 0.80 0.80))
-(define gray81 (make-color 0.81 0.81 0.81))
-(define grey81 (make-color 0.81 0.81 0.81))
-(define gray82 (make-color 0.82 0.82 0.82))
-(define grey82 (make-color 0.82 0.82 0.82))
-(define gray83 (make-color 0.83 0.83 0.83))
-(define grey83 (make-color 0.83 0.83 0.83))
-(define gray84 (make-color 0.84 0.84 0.84))
-(define grey84 (make-color 0.84 0.84 0.84))
-(define gray85 (make-color 0.85 0.85 0.85))
-(define grey85 (make-color 0.85 0.85 0.85))
-(define gray86 (make-color 0.86 0.86 0.86))
-(define grey86 (make-color 0.86 0.86 0.86))
-(define gray87 (make-color 0.87 0.87 0.87))
-(define grey87 (make-color 0.87 0.87 0.87))
-(define gray88 (make-color 0.87 0.87 0.87))
-(define grey88 (make-color 0.87 0.87 0.87))
-(define gray89 (make-color 0.89 0.89 0.89))
-(define grey89 (make-color 0.89 0.89 0.89))
-(define gray90 (make-color 0.89 0.89 0.89))
-(define grey90 (make-color 0.89 0.89 0.89))
-(define gray91 (make-color 0.91 0.91 0.91))
-(define grey91 (make-color 0.91 0.91 0.91))
-(define gray92 (make-color 0.92 0.92 0.92))
-(define grey92 (make-color 0.92 0.92 0.92))
-(define gray93 (make-color 0.93 0.93 0.93))
-(define grey93 (make-color 0.93 0.93 0.93))
-(define gray94 (make-color 0.94 0.94 0.94))
-(define grey94 (make-color 0.94 0.94 0.94))
-(define gray95 (make-color 0.95 0.95 0.95))
-(define grey95 (make-color 0.95 0.95 0.95))
-(define gray96 (make-color 0.96 0.96 0.96))
-(define grey96 (make-color 0.96 0.96 0.96))
-(define gray97 (make-color 0.96 0.96 0.96))
-(define grey97 (make-color 0.96 0.96 0.96))
-(define gray98 (make-color 0.98 0.98 0.98))
-(define grey98 (make-color 0.98 0.98 0.98))
-(define gray99 (make-color 0.98 0.98 0.98))
-(define grey99 (make-color 0.98 0.98 0.98))
-(define gray100 (make-color 1.00 1.00 1.00))
-(define grey100 (make-color 1.00 1.00 1.00))
-(define dark-grey (make-color 0.66 0.66 0.66))
-(define dark-gray (make-color 0.66 0.66 0.66))
-(define dark-blue (make-color 0.00 0.00 0.54))
-(define dark-cyan (make-color 0.00 0.54 0.54))
-(define dark-magenta (make-color 0.54 0.00 0.54))
-(define dark-red (make-color 0.54 0.00 0.00))
-(define light-green (make-color 0.56 0.93 0.56))
-
-(curlet)))
+ (let ((snow (make-color 1.00 0.98 0.98))
+ (ghost-white (make-color 0.97 0.97 1.00))
+ (white-smoke (make-color 0.96 0.96 0.96))
+ (gainsboro (make-color 0.86 0.86 0.86))
+ (floral-white (make-color 1.00 0.98 0.94))
+ (old-lace (make-color 0.99 0.96 0.90))
+ (linen (make-color 0.98 0.94 0.90))
+ (antique-white (make-color 0.98 0.92 0.84))
+ (papaya-whip (make-color 1.00 0.93 0.83))
+ (blanched-almond (make-color 1.00 0.92 0.80))
+ (bisque (make-color 1.00 0.89 0.77))
+ (peach-puff (make-color 1.00 0.85 0.72))
+ (navajo-white (make-color 1.00 0.87 0.68))
+ (moccasin (make-color 1.00 0.89 0.71))
+ (cornsilk (make-color 1.00 0.97 0.86))
+ (ivory (make-color 1.00 1.00 0.94))
+ (lemon-chiffon (make-color 1.00 0.98 0.80))
+ (seashell (make-color 1.00 0.96 0.93))
+ (honeydew (make-color 0.94 1.00 0.94))
+ (mint-cream (make-color 0.96 1.00 0.98))
+ (azure (make-color 0.94 1.00 1.00))
+ (alice-blue (make-color 0.94 0.97 1.00))
+ (lavender (make-color 0.90 0.90 0.98))
+ (lavender-blush (make-color 1.00 0.94 0.96))
+ (misty-rose (make-color 1.00 0.89 0.88))
+ (white (make-color 1.00 1.00 1.00))
+ (black (make-color 0.00 0.00 0.00))
+ (dark-slate-gray (make-color 0.18 0.31 0.31))
+ (dark-slate-grey (make-color 0.18 0.31 0.31))
+ (dim-gray (make-color 0.41 0.41 0.41))
+ (dim-grey (make-color 0.41 0.41 0.41))
+ (slate-gray (make-color 0.44 0.50 0.56))
+ (slate-grey (make-color 0.44 0.50 0.56))
+ (light-slate-gray (make-color 0.46 0.53 0.60))
+ (light-slate-grey (make-color 0.46 0.53 0.60))
+ (gray (make-color 0.74 0.74 0.74))
+ (grey (make-color 0.74 0.74 0.74))
+ (light-grey (make-color 0.82 0.82 0.82))
+ (light-gray (make-color 0.82 0.82 0.82))
+ (midnight-blue (make-color 0.10 0.10 0.44))
+ (navy (make-color 0.00 0.00 0.50))
+ (navy-blue (make-color 0.00 0.00 0.50))
+ (cornflower-blue (make-color 0.39 0.58 0.93))
+ (dark-slate-blue (make-color 0.28 0.24 0.54))
+ (slate-blue (make-color 0.41 0.35 0.80))
+ (medium-slate-blue (make-color 0.48 0.41 0.93))
+ (light-slate-blue (make-color 0.52 0.44 1.00))
+ (medium-blue (make-color 0.00 0.00 0.80))
+ (royal-blue (make-color 0.25 0.41 0.88))
+ (blue (make-color 0.00 0.00 1.00))
+ (dodger-blue (make-color 0.12 0.56 1.00))
+ (deep-sky-blue (make-color 0.00 0.75 1.00))
+ (sky-blue (make-color 0.53 0.80 0.92))
+ (light-sky-blue (make-color 0.53 0.80 0.98))
+ (steel-blue (make-color 0.27 0.51 0.70))
+ (light-steel-blue (make-color 0.69 0.77 0.87))
+ (light-blue (make-color 0.68 0.84 0.90))
+ (powder-blue (make-color 0.69 0.87 0.90))
+ (pale-turquoise (make-color 0.68 0.93 0.93))
+ (dark-turquoise (make-color 0.00 0.80 0.82))
+ (medium-turquoise (make-color 0.28 0.82 0.80))
+ (turquoise (make-color 0.25 0.87 0.81))
+ (cyan (make-color 0.00 1.00 1.00))
+ (light-cyan (make-color 0.87 1.00 1.00))
+ (cadet-blue (make-color 0.37 0.62 0.62))
+ (medium-aquamarine (make-color 0.40 0.80 0.66))
+ (aquamarine (make-color 0.50 1.00 0.83))
+ (dark-green (make-color 0.00 0.39 0.00))
+ (dark-olive-green (make-color 0.33 0.42 0.18))
+ (dark-sea-green (make-color 0.56 0.73 0.56))
+ (sea-green (make-color 0.18 0.54 0.34))
+ (medium-sea-green (make-color 0.23 0.70 0.44))
+ (light-sea-green (make-color 0.12 0.70 0.66))
+ (pale-green (make-color 0.59 0.98 0.59))
+ (spring-green (make-color 0.00 1.00 0.50))
+ (lawn-green (make-color 0.48 0.98 0.00))
+ (green (make-color 0.00 1.00 0.00))
+ (chartreuse (make-color 0.50 1.00 0.00))
+ (medium-spring-green (make-color 0.00 0.98 0.60))
+ (green-yellow (make-color 0.68 1.00 0.18))
+ (lime-green (make-color 0.20 0.80 0.20))
+ (yellow-green (make-color 0.60 0.80 0.20))
+ (forest-green (make-color 0.13 0.54 0.13))
+ (olive-drab (make-color 0.42 0.55 0.14))
+ (dark-khaki (make-color 0.74 0.71 0.42))
+ (khaki (make-color 0.94 0.90 0.55))
+ (pale-goldenrod (make-color 0.93 0.91 0.66))
+ (light-goldenrod-yellow (make-color 0.98 0.98 0.82))
+ (light-yellow (make-color 1.00 1.00 0.87))
+ (yellow (make-color 1.00 1.00 0.00))
+ (gold (make-color 1.00 0.84 0.00))
+ (light-goldenrod (make-color 0.93 0.86 0.51))
+ (goldenrod (make-color 0.85 0.64 0.12))
+ (dark-goldenrod (make-color 0.72 0.52 0.04))
+ (rosy-brown (make-color 0.73 0.56 0.56))
+ (indian-red (make-color 0.80 0.36 0.36))
+ (saddle-brown (make-color 0.54 0.27 0.07))
+ (sienna (make-color 0.62 0.32 0.18))
+ (peru (make-color 0.80 0.52 0.25))
+ (burlywood (make-color 0.87 0.72 0.53))
+ (beige (make-color 0.96 0.96 0.86))
+ (wheat (make-color 0.96 0.87 0.70))
+ (sandy-brown (make-color 0.95 0.64 0.37))
+ (tawny (make-color 0.82 0.70 0.55)) ; tan collides with Scheme built-in -- tawny suggested by Dave Phillips
+ (chocolate (make-color 0.82 0.41 0.12))
+ (firebrick (make-color 0.70 0.13 0.13))
+ (brown (make-color 0.64 0.16 0.16))
+ (dark-salmon (make-color 0.91 0.59 0.48))
+ (salmon (make-color 0.98 0.50 0.45))
+ (light-salmon (make-color 1.00 0.62 0.48))
+ (orange (make-color 1.00 0.64 0.00))
+ (dark-orange (make-color 1.00 0.55 0.00))
+ (coral (make-color 1.00 0.50 0.31))
+ (light-coral (make-color 0.94 0.50 0.50))
+ (tomato (make-color 1.00 0.39 0.28))
+ (orange-red (make-color 1.00 0.27 0.00))
+ (red (make-color 1.00 0.00 0.00))
+ (hot-pink (make-color 1.00 0.41 0.70))
+ (deep-pink (make-color 1.00 0.08 0.57))
+ (pink (make-color 1.00 0.75 0.79))
+ (light-pink (make-color 1.00 0.71 0.75))
+ (pale-violet-red (make-color 0.86 0.44 0.57))
+ (maroon (make-color 0.69 0.19 0.37))
+ (medium-violet-red (make-color 0.78 0.08 0.52))
+ (violet-red (make-color 0.81 0.12 0.56))
+ (magenta (make-color 1.00 0.00 1.00))
+ (violet (make-color 0.93 0.51 0.93))
+ (plum (make-color 0.86 0.62 0.86))
+ (orchid (make-color 0.85 0.44 0.84))
+ (medium-orchid (make-color 0.73 0.33 0.82))
+ (dark-orchid (make-color 0.60 0.20 0.80))
+ (dark-violet (make-color 0.58 0.00 0.82))
+ (blue-violet (make-color 0.54 0.17 0.88))
+ (purple (make-color 0.62 0.12 0.94))
+ (medium-purple (make-color 0.57 0.44 0.86))
+ (thistle (make-color 0.84 0.75 0.84))
+ (snow1 (make-color 1.00 0.98 0.98))
+ (snow2 (make-color 0.93 0.91 0.91))
+ (snow3 (make-color 0.80 0.79 0.79))
+ (snow4 (make-color 0.54 0.54 0.54))
+ (seashell1 (make-color 1.00 0.96 0.93))
+ (seashell2 (make-color 0.93 0.89 0.87))
+ (seashell3 (make-color 0.80 0.77 0.75))
+ (seashell4 (make-color 0.54 0.52 0.51))
+ (antiquewhite1 (make-color 1.00 0.93 0.86))
+ (antiquewhite2 (make-color 0.93 0.87 0.80))
+ (antiquewhite3 (make-color 0.80 0.75 0.69))
+ (antiquewhite4 (make-color 0.54 0.51 0.47))
+ (bisque1 (make-color 1.00 0.89 0.77))
+ (bisque2 (make-color 0.93 0.83 0.71))
+ (bisque3 (make-color 0.80 0.71 0.62))
+ (bisque4 (make-color 0.54 0.49 0.42))
+ (peachpuff1 (make-color 1.00 0.85 0.72))
+ (peachpuff2 (make-color 0.93 0.79 0.68))
+ (peachpuff3 (make-color 0.80 0.68 0.58))
+ (peachpuff4 (make-color 0.54 0.46 0.39))
+ (navajowhite1 (make-color 1.00 0.87 0.68))
+ (navajowhite2 (make-color 0.93 0.81 0.63))
+ (navajowhite3 (make-color 0.80 0.70 0.54))
+ (navajowhite4 (make-color 0.54 0.47 0.37))
+ (lemonchiffon1 (make-color 1.00 0.98 0.80))
+ (lemonchiffon2 (make-color 0.93 0.91 0.75))
+ (lemonchiffon3 (make-color 0.80 0.79 0.64))
+ (lemonchiffon4 (make-color 0.54 0.54 0.44))
+ (cornsilk1 (make-color 1.00 0.97 0.86))
+ (cornsilk2 (make-color 0.93 0.91 0.80))
+ (cornsilk3 (make-color 0.80 0.78 0.69))
+ (cornsilk4 (make-color 0.54 0.53 0.47))
+ (ivory1 (make-color 1.00 1.00 0.94))
+ (ivory2 (make-color 0.93 0.93 0.87))
+ (ivory3 (make-color 0.80 0.80 0.75))
+ (ivory4 (make-color 0.54 0.54 0.51))
+ (honeydew1 (make-color 0.94 1.00 0.94))
+ (honeydew2 (make-color 0.87 0.93 0.87))
+ (honeydew3 (make-color 0.75 0.80 0.75))
+ (honeydew4 (make-color 0.51 0.54 0.51))
+ (lavenderblush1 (make-color 1.00 0.94 0.96))
+ (lavenderblush2 (make-color 0.93 0.87 0.89))
+ (lavenderblush3 (make-color 0.80 0.75 0.77))
+ (lavenderblush4 (make-color 0.54 0.51 0.52))
+ (mistyrose1 (make-color 1.00 0.89 0.88))
+ (mistyrose2 (make-color 0.93 0.83 0.82))
+ (mistyrose3 (make-color 0.80 0.71 0.71))
+ (mistyrose4 (make-color 0.54 0.49 0.48))
+ (azure1 (make-color 0.94 1.00 1.00))
+ (azure2 (make-color 0.87 0.93 0.93))
+ (azure3 (make-color 0.75 0.80 0.80))
+ (azure4 (make-color 0.51 0.54 0.54))
+ (slateblue1 (make-color 0.51 0.43 1.00))
+ (slateblue2 (make-color 0.48 0.40 0.93))
+ (slateblue3 (make-color 0.41 0.35 0.80))
+ (slateblue4 (make-color 0.28 0.23 0.54))
+ (royalblue1 (make-color 0.28 0.46 1.00))
+ (royalblue2 (make-color 0.26 0.43 0.93))
+ (royalblue3 (make-color 0.23 0.37 0.80))
+ (royalblue4 (make-color 0.15 0.25 0.54))
+ (blue1 (make-color 0.00 0.00 1.00))
+ (blue2 (make-color 0.00 0.00 0.93))
+ (blue3 (make-color 0.00 0.00 0.80))
+ (blue4 (make-color 0.00 0.00 0.54))
+ (dodgerblue1 (make-color 0.12 0.56 1.00))
+ (dodgerblue2 (make-color 0.11 0.52 0.93))
+ (dodgerblue3 (make-color 0.09 0.45 0.80))
+ (dodgerblue4 (make-color 0.06 0.30 0.54))
+ (steelblue1 (make-color 0.39 0.72 1.00))
+ (steelblue2 (make-color 0.36 0.67 0.93))
+ (steelblue3 (make-color 0.31 0.58 0.80))
+ (steelblue4 (make-color 0.21 0.39 0.54))
+ (deepskyblue1 (make-color 0.00 0.75 1.00))
+ (deepskyblue2 (make-color 0.00 0.70 0.93))
+ (deepskyblue3 (make-color 0.00 0.60 0.80))
+ (deepskyblue4 (make-color 0.00 0.41 0.54))
+ (skyblue1 (make-color 0.53 0.80 1.00))
+ (skyblue2 (make-color 0.49 0.75 0.93))
+ (skyblue3 (make-color 0.42 0.65 0.80))
+ (skyblue4 (make-color 0.29 0.44 0.54))
+ (lightskyblue1 (make-color 0.69 0.88 1.00))
+ (lightskyblue2 (make-color 0.64 0.82 0.93))
+ (lightskyblue3 (make-color 0.55 0.71 0.80))
+ (lightskyblue4 (make-color 0.37 0.48 0.54))
+ (slategray1 (make-color 0.77 0.88 1.00))
+ (slategray2 (make-color 0.72 0.82 0.93))
+ (slategray3 (make-color 0.62 0.71 0.80))
+ (slategray4 (make-color 0.42 0.48 0.54))
+ (lightsteelblue1 (make-color 0.79 0.88 1.00))
+ (lightsteelblue2 (make-color 0.73 0.82 0.93))
+ (lightsteelblue3 (make-color 0.63 0.71 0.80))
+ (lightsteelblue4 (make-color 0.43 0.48 0.54))
+ (lightblue1 (make-color 0.75 0.93 1.00))
+ (lightblue2 (make-color 0.70 0.87 0.93))
+ (lightblue3 (make-color 0.60 0.75 0.80))
+ (lightblue4 (make-color 0.41 0.51 0.54))
+ (lightcyan1 (make-color 0.87 1.00 1.00))
+ (lightcyan2 (make-color 0.82 0.93 0.93))
+ (lightcyan3 (make-color 0.70 0.80 0.80))
+ (lightcyan4 (make-color 0.48 0.54 0.54))
+ (paleturquoise1 (make-color 0.73 1.00 1.00))
+ (paleturquoise2 (make-color 0.68 0.93 0.93))
+ (paleturquoise3 (make-color 0.59 0.80 0.80))
+ (paleturquoise4 (make-color 0.40 0.54 0.54))
+ (cadetblue1 (make-color 0.59 0.96 1.00))
+ (cadetblue2 (make-color 0.55 0.89 0.93))
+ (cadetblue3 (make-color 0.48 0.77 0.80))
+ (cadetblue4 (make-color 0.32 0.52 0.54))
+ (turquoise1 (make-color 0.00 0.96 1.00))
+ (turquoise2 (make-color 0.00 0.89 0.93))
+ (turquoise3 (make-color 0.00 0.77 0.80))
+ (turquoise4 (make-color 0.00 0.52 0.54))
+ (cyan1 (make-color 0.00 1.00 1.00))
+ (cyan2 (make-color 0.00 0.93 0.93))
+ (cyan3 (make-color 0.00 0.80 0.80))
+ (cyan4 (make-color 0.00 0.54 0.54))
+ (darkslategray1 (make-color 0.59 1.00 1.00))
+ (darkslategray2 (make-color 0.55 0.93 0.93))
+ (darkslategray3 (make-color 0.47 0.80 0.80))
+ (darkslategray4 (make-color 0.32 0.54 0.54))
+ (aquamarine1 (make-color 0.50 1.00 0.83))
+ (aquamarine2 (make-color 0.46 0.93 0.77))
+ (aquamarine3 (make-color 0.40 0.80 0.66))
+ (aquamarine4 (make-color 0.27 0.54 0.45))
+ (darkseagreen1 (make-color 0.75 1.00 0.75))
+ (darkseagreen2 (make-color 0.70 0.93 0.70))
+ (darkseagreen3 (make-color 0.61 0.80 0.61))
+ (darkseagreen4 (make-color 0.41 0.54 0.41))
+ (seagreen1 (make-color 0.33 1.00 0.62))
+ (seagreen2 (make-color 0.30 0.93 0.58))
+ (seagreen3 (make-color 0.26 0.80 0.50))
+ (seagreen4 (make-color 0.18 0.54 0.34))
+ (palegreen1 (make-color 0.60 1.00 0.60))
+ (palegreen2 (make-color 0.56 0.93 0.56))
+ (palegreen3 (make-color 0.48 0.80 0.48))
+ (palegreen4 (make-color 0.33 0.54 0.33))
+ (springgreen1 (make-color 0.00 1.00 0.50))
+ (springgreen2 (make-color 0.00 0.93 0.46))
+ (springgreen3 (make-color 0.00 0.80 0.40))
+ (springgreen4 (make-color 0.00 0.54 0.27))
+ (green1 (make-color 0.00 1.00 0.00))
+ (green2 (make-color 0.00 0.93 0.00))
+ (green3 (make-color 0.00 0.80 0.00))
+ (green4 (make-color 0.00 0.54 0.00))
+ (chartreuse1 (make-color 0.50 1.00 0.00))
+ (chartreuse2 (make-color 0.46 0.93 0.00))
+ (chartreuse3 (make-color 0.40 0.80 0.00))
+ (chartreuse4 (make-color 0.27 0.54 0.00))
+ (olivedrab1 (make-color 0.75 1.00 0.24))
+ (olivedrab2 (make-color 0.70 0.93 0.23))
+ (olivedrab3 (make-color 0.60 0.80 0.20))
+ (olivedrab4 (make-color 0.41 0.54 0.13))
+ (darkolivegreen1 (make-color 0.79 1.00 0.44))
+ (darkolivegreen2 (make-color 0.73 0.93 0.41))
+ (darkolivegreen3 (make-color 0.63 0.80 0.35))
+ (darkolivegreen4 (make-color 0.43 0.54 0.24))
+ (khaki1 (make-color 1.00 0.96 0.56))
+ (khaki2 (make-color 0.93 0.90 0.52))
+ (khaki3 (make-color 0.80 0.77 0.45))
+ (khaki4 (make-color 0.54 0.52 0.30))
+ (lightgoldenrod1 (make-color 1.00 0.92 0.54))
+ (lightgoldenrod2 (make-color 0.93 0.86 0.51))
+ (lightgoldenrod3 (make-color 0.80 0.74 0.44))
+ (lightgoldenrod4 (make-color 0.54 0.50 0.30))
+ (lightyellow1 (make-color 1.00 1.00 0.87))
+ (lightyellow2 (make-color 0.93 0.93 0.82))
+ (lightyellow3 (make-color 0.80 0.80 0.70))
+ (lightyellow4 (make-color 0.54 0.54 0.48))
+ (yellow1 (make-color 1.00 1.00 0.00))
+ (yellow2 (make-color 0.93 0.93 0.00))
+ (yellow3 (make-color 0.80 0.80 0.00))
+ (yellow4 (make-color 0.54 0.54 0.00))
+ (gold1 (make-color 1.00 0.84 0.00))
+ (gold2 (make-color 0.93 0.79 0.00))
+ (gold3 (make-color 0.80 0.68 0.00))
+ (gold4 (make-color 0.54 0.46 0.00))
+ (goldenrod1 (make-color 1.00 0.75 0.14))
+ (goldenrod2 (make-color 0.93 0.70 0.13))
+ (goldenrod3 (make-color 0.80 0.61 0.11))
+ (goldenrod4 (make-color 0.54 0.41 0.08))
+ (darkgoldenrod1 (make-color 1.00 0.72 0.06))
+ (darkgoldenrod2 (make-color 0.93 0.68 0.05))
+ (darkgoldenrod3 (make-color 0.80 0.58 0.05))
+ (darkgoldenrod4 (make-color 0.54 0.39 0.03))
+ (rosybrown1 (make-color 1.00 0.75 0.75))
+ (rosybrown2 (make-color 0.93 0.70 0.70))
+ (rosybrown3 (make-color 0.80 0.61 0.61))
+ (rosybrown4 (make-color 0.54 0.41 0.41))
+ (indianred1 (make-color 1.00 0.41 0.41))
+ (indianred2 (make-color 0.93 0.39 0.39))
+ (indianred3 (make-color 0.80 0.33 0.33))
+ (indianred4 (make-color 0.54 0.23 0.23))
+ (sienna1 (make-color 1.00 0.51 0.28))
+ (sienna2 (make-color 0.93 0.47 0.26))
+ (sienna3 (make-color 0.80 0.41 0.22))
+ (sienna4 (make-color 0.54 0.28 0.15))
+ (burlywood1 (make-color 1.00 0.82 0.61))
+ (burlywood2 (make-color 0.93 0.77 0.57))
+ (burlywood3 (make-color 0.80 0.66 0.49))
+ (burlywood4 (make-color 0.54 0.45 0.33))
+ (wheat1 (make-color 1.00 0.90 0.73))
+ (wheat2 (make-color 0.93 0.84 0.68))
+ (wheat3 (make-color 0.80 0.73 0.59))
+ (wheat4 (make-color 0.54 0.49 0.40))
+ (tan1 (make-color 1.00 0.64 0.31))
+ (tan2 (make-color 0.93 0.60 0.29))
+ (tan3 (make-color 0.80 0.52 0.25))
+ (tan4 (make-color 0.54 0.35 0.17))
+ (chocolate1 (make-color 1.00 0.50 0.14))
+ (chocolate2 (make-color 0.93 0.46 0.13))
+ (chocolate3 (make-color 0.80 0.40 0.11))
+ (chocolate4 (make-color 0.54 0.27 0.07))
+ (firebrick1 (make-color 1.00 0.19 0.19))
+ (firebrick2 (make-color 0.93 0.17 0.17))
+ (firebrick3 (make-color 0.80 0.15 0.15))
+ (firebrick4 (make-color 0.54 0.10 0.10))
+ (brown1 (make-color 1.00 0.25 0.25))
+ (brown2 (make-color 0.93 0.23 0.23))
+ (brown3 (make-color 0.80 0.20 0.20))
+ (brown4 (make-color 0.54 0.14 0.14))
+ (salmon1 (make-color 1.00 0.55 0.41))
+ (salmon2 (make-color 0.93 0.51 0.38))
+ (salmon3 (make-color 0.80 0.44 0.33))
+ (salmon4 (make-color 0.54 0.30 0.22))
+ (lightsalmon1 (make-color 1.00 0.62 0.48))
+ (lightsalmon2 (make-color 0.93 0.58 0.45))
+ (lightsalmon3 (make-color 0.80 0.50 0.38))
+ (lightsalmon4 (make-color 0.54 0.34 0.26))
+ (orange1 (make-color 1.00 0.64 0.00))
+ (orange2 (make-color 0.93 0.60 0.00))
+ (orange3 (make-color 0.80 0.52 0.00))
+ (orange4 (make-color 0.54 0.35 0.00))
+ (darkorange1 (make-color 1.00 0.50 0.00))
+ (darkorange2 (make-color 0.93 0.46 0.00))
+ (darkorange3 (make-color 0.80 0.40 0.00))
+ (darkorange4 (make-color 0.54 0.27 0.00))
+ (coral1 (make-color 1.00 0.45 0.34))
+ (coral2 (make-color 0.93 0.41 0.31))
+ (coral3 (make-color 0.80 0.36 0.27))
+ (coral4 (make-color 0.54 0.24 0.18))
+ (tomato1 (make-color 1.00 0.39 0.28))
+ (tomato2 (make-color 0.93 0.36 0.26))
+ (tomato3 (make-color 0.80 0.31 0.22))
+ (tomato4 (make-color 0.54 0.21 0.15))
+ (orangered1 (make-color 1.00 0.27 0.00))
+ (orangered2 (make-color 0.93 0.25 0.00))
+ (orangered3 (make-color 0.80 0.21 0.00))
+ (orangered4 (make-color 0.54 0.14 0.00))
+ (red1 (make-color 1.00 0.00 0.00))
+ (red2 (make-color 0.93 0.00 0.00))
+ (red3 (make-color 0.80 0.00 0.00))
+ (red4 (make-color 0.54 0.00 0.00))
+ (deeppink1 (make-color 1.00 0.08 0.57))
+ (deeppink2 (make-color 0.93 0.07 0.54))
+ (deeppink3 (make-color 0.80 0.06 0.46))
+ (deeppink4 (make-color 0.54 0.04 0.31))
+ (hotpink1 (make-color 1.00 0.43 0.70))
+ (hotpink2 (make-color 0.93 0.41 0.65))
+ (hotpink3 (make-color 0.80 0.37 0.56))
+ (hotpink4 (make-color 0.54 0.23 0.38))
+ (pink1 (make-color 1.00 0.71 0.77))
+ (pink2 (make-color 0.93 0.66 0.72))
+ (pink3 (make-color 0.80 0.57 0.62))
+ (pink4 (make-color 0.54 0.39 0.42))
+ (lightpink1 (make-color 1.00 0.68 0.72))
+ (lightpink2 (make-color 0.93 0.63 0.68))
+ (lightpink3 (make-color 0.80 0.55 0.58))
+ (lightpink4 (make-color 0.54 0.37 0.39))
+ (palevioletred1 (make-color 1.00 0.51 0.67))
+ (palevioletred2 (make-color 0.93 0.47 0.62))
+ (palevioletred3 (make-color 0.80 0.41 0.54))
+ (palevioletred4 (make-color 0.54 0.28 0.36))
+ (maroon1 (make-color 1.00 0.20 0.70))
+ (maroon2 (make-color 0.93 0.19 0.65))
+ (maroon3 (make-color 0.80 0.16 0.56))
+ (maroon4 (make-color 0.54 0.11 0.38))
+ (violetred1 (make-color 1.00 0.24 0.59))
+ (violetred2 (make-color 0.93 0.23 0.55))
+ (violetred3 (make-color 0.80 0.20 0.47))
+ (violetred4 (make-color 0.54 0.13 0.32))
+ (magenta1 (make-color 1.00 0.00 1.00))
+ (magenta2 (make-color 0.93 0.00 0.93))
+ (magenta3 (make-color 0.80 0.00 0.80))
+ (magenta4 (make-color 0.54 0.00 0.54))
+ (orchid1 (make-color 1.00 0.51 0.98))
+ (orchid2 (make-color 0.93 0.48 0.91))
+ (orchid3 (make-color 0.80 0.41 0.79))
+ (orchid4 (make-color 0.54 0.28 0.54))
+ (plum1 (make-color 1.00 0.73 1.00))
+ (plum2 (make-color 0.93 0.68 0.93))
+ (plum3 (make-color 0.80 0.59 0.80))
+ (plum4 (make-color 0.54 0.40 0.54))
+ (mediumorchid1 (make-color 0.87 0.40 1.00))
+ (mediumorchid2 (make-color 0.82 0.37 0.93))
+ (mediumorchid3 (make-color 0.70 0.32 0.80))
+ (mediumorchid4 (make-color 0.48 0.21 0.54))
+ (darkorchid1 (make-color 0.75 0.24 1.00))
+ (darkorchid2 (make-color 0.70 0.23 0.93))
+ (darkorchid3 (make-color 0.60 0.20 0.80))
+ (darkorchid4 (make-color 0.41 0.13 0.54))
+ (purple1 (make-color 0.61 0.19 1.00))
+ (purple2 (make-color 0.57 0.17 0.93))
+ (purple3 (make-color 0.49 0.15 0.80))
+ (purple4 (make-color 0.33 0.10 0.54))
+ (mediumpurple1 (make-color 0.67 0.51 1.00))
+ (mediumpurple2 (make-color 0.62 0.47 0.93))
+ (mediumpurple3 (make-color 0.54 0.41 0.80))
+ (mediumpurple4 (make-color 0.36 0.28 0.54))
+ (thistle1 (make-color 1.00 0.88 1.00))
+ (thistle2 (make-color 0.93 0.82 0.93))
+ (thistle3 (make-color 0.80 0.71 0.80))
+ (thistle4 (make-color 0.54 0.48 0.54))
+ (gray0 (make-color 0.00 0.00 0.00))
+ (grey0 (make-color 0.00 0.00 0.00))
+ (gray1 (make-color 0.01 0.01 0.01))
+ (grey1 (make-color 0.01 0.01 0.01))
+ (gray2 (make-color 0.02 0.02 0.02))
+ (grey2 (make-color 0.02 0.02 0.02))
+ (gray3 (make-color 0.03 0.03 0.03))
+ (grey3 (make-color 0.03 0.03 0.03))
+ (gray4 (make-color 0.04 0.04 0.04))
+ (grey4 (make-color 0.04 0.04 0.04))
+ (gray5 (make-color 0.05 0.05 0.05))
+ (grey5 (make-color 0.05 0.05 0.05))
+ (gray6 (make-color 0.06 0.06 0.06))
+ (grey6 (make-color 0.06 0.06 0.06))
+ (gray7 (make-color 0.07 0.07 0.07))
+ (grey7 (make-color 0.07 0.07 0.07))
+ (gray8 (make-color 0.08 0.08 0.08))
+ (grey8 (make-color 0.08 0.08 0.08))
+ (gray9 (make-color 0.09 0.09 0.09))
+ (grey9 (make-color 0.09 0.09 0.09))
+ (gray10 (make-color 0.10 0.10 0.10))
+ (grey10 (make-color 0.10 0.10 0.10))
+ (gray11 (make-color 0.11 0.11 0.11))
+ (grey11 (make-color 0.11 0.11 0.11))
+ (gray12 (make-color 0.12 0.12 0.12))
+ (grey12 (make-color 0.12 0.12 0.12))
+ (gray13 (make-color 0.13 0.13 0.13))
+ (grey13 (make-color 0.13 0.13 0.13))
+ (gray14 (make-color 0.14 0.14 0.14))
+ (grey14 (make-color 0.14 0.14 0.14))
+ (gray15 (make-color 0.15 0.15 0.15))
+ (grey15 (make-color 0.15 0.15 0.15))
+ (gray16 (make-color 0.16 0.16 0.16))
+ (grey16 (make-color 0.16 0.16 0.16))
+ (gray17 (make-color 0.17 0.17 0.17))
+ (grey17 (make-color 0.17 0.17 0.17))
+ (gray18 (make-color 0.18 0.18 0.18))
+ (grey18 (make-color 0.18 0.18 0.18))
+ (gray19 (make-color 0.19 0.19 0.19))
+ (grey19 (make-color 0.19 0.19 0.19))
+ (gray20 (make-color 0.20 0.20 0.20))
+ (grey20 (make-color 0.20 0.20 0.20))
+ (gray21 (make-color 0.21 0.21 0.21))
+ (grey21 (make-color 0.21 0.21 0.21))
+ (gray22 (make-color 0.22 0.22 0.22))
+ (grey22 (make-color 0.22 0.22 0.22))
+ (gray23 (make-color 0.23 0.23 0.23))
+ (grey23 (make-color 0.23 0.23 0.23))
+ (gray24 (make-color 0.24 0.24 0.24))
+ (grey24 (make-color 0.24 0.24 0.24))
+ (gray25 (make-color 0.25 0.25 0.25))
+ (grey25 (make-color 0.25 0.25 0.25))
+ (gray26 (make-color 0.26 0.26 0.26))
+ (grey26 (make-color 0.26 0.26 0.26))
+ (gray27 (make-color 0.27 0.27 0.27))
+ (grey27 (make-color 0.27 0.27 0.27))
+ (gray28 (make-color 0.28 0.28 0.28))
+ (grey28 (make-color 0.28 0.28 0.28))
+ (gray29 (make-color 0.29 0.29 0.29))
+ (grey29 (make-color 0.29 0.29 0.29))
+ (gray30 (make-color 0.30 0.30 0.30))
+ (grey30 (make-color 0.30 0.30 0.30))
+ (gray31 (make-color 0.31 0.31 0.31))
+ (grey31 (make-color 0.31 0.31 0.31))
+ (gray32 (make-color 0.32 0.32 0.32))
+ (grey32 (make-color 0.32 0.32 0.32))
+ (gray33 (make-color 0.33 0.33 0.33))
+ (grey33 (make-color 0.33 0.33 0.33))
+ (gray34 (make-color 0.34 0.34 0.34))
+ (grey34 (make-color 0.34 0.34 0.34))
+ (gray35 (make-color 0.35 0.35 0.35))
+ (grey35 (make-color 0.35 0.35 0.35))
+ (gray36 (make-color 0.36 0.36 0.36))
+ (grey36 (make-color 0.36 0.36 0.36))
+ (gray37 (make-color 0.37 0.37 0.37))
+ (grey37 (make-color 0.37 0.37 0.37))
+ (gray38 (make-color 0.38 0.38 0.38))
+ (grey38 (make-color 0.38 0.38 0.38))
+ (gray39 (make-color 0.39 0.39 0.39))
+ (grey39 (make-color 0.39 0.39 0.39))
+ (gray40 (make-color 0.40 0.40 0.40))
+ (grey40 (make-color 0.40 0.40 0.40))
+ (gray41 (make-color 0.41 0.41 0.41))
+ (grey41 (make-color 0.41 0.41 0.41))
+ (gray42 (make-color 0.42 0.42 0.42))
+ (grey42 (make-color 0.42 0.42 0.42))
+ (gray43 (make-color 0.43 0.43 0.43))
+ (grey43 (make-color 0.43 0.43 0.43))
+ (gray44 (make-color 0.44 0.44 0.44))
+ (grey44 (make-color 0.44 0.44 0.44))
+ (gray45 (make-color 0.45 0.45 0.45))
+ (grey45 (make-color 0.45 0.45 0.45))
+ (gray46 (make-color 0.46 0.46 0.46))
+ (grey46 (make-color 0.46 0.46 0.46))
+ (gray47 (make-color 0.47 0.47 0.47))
+ (grey47 (make-color 0.47 0.47 0.47))
+ (gray48 (make-color 0.48 0.48 0.48))
+ (grey48 (make-color 0.48 0.48 0.48))
+ (gray49 (make-color 0.49 0.49 0.49))
+ (grey49 (make-color 0.49 0.49 0.49))
+ (gray50 (make-color 0.50 0.50 0.50))
+ (grey50 (make-color 0.50 0.50 0.50))
+ (gray51 (make-color 0.51 0.51 0.51))
+ (grey51 (make-color 0.51 0.51 0.51))
+ (gray52 (make-color 0.52 0.52 0.52))
+ (grey52 (make-color 0.52 0.52 0.52))
+ (gray53 (make-color 0.53 0.53 0.53))
+ (grey53 (make-color 0.53 0.53 0.53))
+ (gray54 (make-color 0.54 0.54 0.54))
+ (grey54 (make-color 0.54 0.54 0.54))
+ (gray55 (make-color 0.55 0.55 0.55))
+ (grey55 (make-color 0.55 0.55 0.55))
+ (gray56 (make-color 0.56 0.56 0.56))
+ (grey56 (make-color 0.56 0.56 0.56))
+ (gray57 (make-color 0.57 0.57 0.57))
+ (grey57 (make-color 0.57 0.57 0.57))
+ (gray58 (make-color 0.58 0.58 0.58))
+ (grey58 (make-color 0.58 0.58 0.58))
+ (gray59 (make-color 0.59 0.59 0.59))
+ (grey59 (make-color 0.59 0.59 0.59))
+ (gray60 (make-color 0.60 0.60 0.60))
+ (grey60 (make-color 0.60 0.60 0.60))
+ (gray61 (make-color 0.61 0.61 0.61))
+ (grey61 (make-color 0.61 0.61 0.61))
+ (gray62 (make-color 0.62 0.62 0.62))
+ (grey62 (make-color 0.62 0.62 0.62))
+ (gray63 (make-color 0.63 0.63 0.63))
+ (grey63 (make-color 0.63 0.63 0.63))
+ (gray64 (make-color 0.64 0.64 0.64))
+ (grey64 (make-color 0.64 0.64 0.64))
+ (gray65 (make-color 0.65 0.65 0.65))
+ (grey65 (make-color 0.65 0.65 0.65))
+ (gray66 (make-color 0.66 0.66 0.66))
+ (grey66 (make-color 0.66 0.66 0.66))
+ (gray67 (make-color 0.67 0.67 0.67))
+ (grey67 (make-color 0.67 0.67 0.67))
+ (gray68 (make-color 0.68 0.68 0.68))
+ (grey68 (make-color 0.68 0.68 0.68))
+ (gray69 (make-color 0.69 0.69 0.69))
+ (grey69 (make-color 0.69 0.69 0.69))
+ (gray70 (make-color 0.70 0.70 0.70))
+ (grey70 (make-color 0.70 0.70 0.70))
+ (gray71 (make-color 0.71 0.71 0.71))
+ (grey71 (make-color 0.71 0.71 0.71))
+ (gray72 (make-color 0.72 0.72 0.72))
+ (grey72 (make-color 0.72 0.72 0.72))
+ (gray73 (make-color 0.73 0.73 0.73))
+ (grey73 (make-color 0.73 0.73 0.73))
+ (gray74 (make-color 0.74 0.74 0.74))
+ (grey74 (make-color 0.74 0.74 0.74))
+ (gray75 (make-color 0.75 0.75 0.75))
+ (grey75 (make-color 0.75 0.75 0.75))
+ (gray76 (make-color 0.76 0.76 0.76))
+ (grey76 (make-color 0.76 0.76 0.76))
+ (gray77 (make-color 0.77 0.77 0.77))
+ (grey77 (make-color 0.77 0.77 0.77))
+ (gray78 (make-color 0.78 0.78 0.78))
+ (grey78 (make-color 0.78 0.78 0.78))
+ (gray79 (make-color 0.79 0.79 0.79))
+ (grey79 (make-color 0.79 0.79 0.79))
+ (gray80 (make-color 0.80 0.80 0.80))
+ (grey80 (make-color 0.80 0.80 0.80))
+ (gray81 (make-color 0.81 0.81 0.81))
+ (grey81 (make-color 0.81 0.81 0.81))
+ (gray82 (make-color 0.82 0.82 0.82))
+ (grey82 (make-color 0.82 0.82 0.82))
+ (gray83 (make-color 0.83 0.83 0.83))
+ (grey83 (make-color 0.83 0.83 0.83))
+ (gray84 (make-color 0.84 0.84 0.84))
+ (grey84 (make-color 0.84 0.84 0.84))
+ (gray85 (make-color 0.85 0.85 0.85))
+ (grey85 (make-color 0.85 0.85 0.85))
+ (gray86 (make-color 0.86 0.86 0.86))
+ (grey86 (make-color 0.86 0.86 0.86))
+ (gray87 (make-color 0.87 0.87 0.87))
+ (grey87 (make-color 0.87 0.87 0.87))
+ (gray88 (make-color 0.87 0.87 0.87))
+ (grey88 (make-color 0.87 0.87 0.87))
+ (gray89 (make-color 0.89 0.89 0.89))
+ (grey89 (make-color 0.89 0.89 0.89))
+ (gray90 (make-color 0.89 0.89 0.89))
+ (grey90 (make-color 0.89 0.89 0.89))
+ (gray91 (make-color 0.91 0.91 0.91))
+ (grey91 (make-color 0.91 0.91 0.91))
+ (gray92 (make-color 0.92 0.92 0.92))
+ (grey92 (make-color 0.92 0.92 0.92))
+ (gray93 (make-color 0.93 0.93 0.93))
+ (grey93 (make-color 0.93 0.93 0.93))
+ (gray94 (make-color 0.94 0.94 0.94))
+ (grey94 (make-color 0.94 0.94 0.94))
+ (gray95 (make-color 0.95 0.95 0.95))
+ (grey95 (make-color 0.95 0.95 0.95))
+ (gray96 (make-color 0.96 0.96 0.96))
+ (grey96 (make-color 0.96 0.96 0.96))
+ (gray97 (make-color 0.96 0.96 0.96))
+ (grey97 (make-color 0.96 0.96 0.96))
+ (gray98 (make-color 0.98 0.98 0.98))
+ (grey98 (make-color 0.98 0.98 0.98))
+ (gray99 (make-color 0.98 0.98 0.98))
+ (grey99 (make-color 0.98 0.98 0.98))
+ (gray100 (make-color 1.00 1.00 1.00))
+ (grey100 (make-color 1.00 1.00 1.00))
+ (dark-grey (make-color 0.66 0.66 0.66))
+ (dark-gray (make-color 0.66 0.66 0.66))
+ (dark-blue (make-color 0.00 0.00 0.54))
+ (dark-cyan (make-color 0.00 0.54 0.54))
+ (dark-magenta (make-color 0.54 0.00 0.54))
+ (dark-red (make-color 0.54 0.00 0.00))
+ (light-green (make-color 0.56 0.93 0.56)))
+ (curlet)))
diff --git a/rubber.scm b/rubber.scm
index a8d60b1..093c6fb 100644
--- a/rubber.scm
+++ b/rubber.scm
@@ -26,8 +26,7 @@
(define* (derumble-sound snd chn)
(let* ((old-length (framples snd chn))
- (pow2 (ceiling (log (min old-length (srate snd)) 2)))
- (fftlen (floor (expt 2 pow2)))
+ (fftlen (floor (expt 2 (ceiling (log (min old-length (srate snd)) 2)))))
(flt-env (list 0.0 0.0 (/ (* 2 16.0) (srate snd)) 0.0 (/ (* 2 20.0) (srate snd)) 1.0 1.0 1.0)))
(filter-sound flt-env fftlen snd chn)
(set! (framples snd chn) old-length)))
@@ -115,11 +114,10 @@
((= i (- crosses 1)))
(let ((start (floor (cross-samples i)))
(autolen 0))
- (let* ((s0 start)
- (pow2 (ceiling (log (* extension (/ (srate snd) 40.0)) 2)))
+ (let* ((pow2 (ceiling (log (* extension (/ (srate snd) 40.0)) 2)))
(fftlen (floor (expt 2 pow2)))
(len4 (/ fftlen 4))
- (data (samples (floor s0) fftlen)))
+ (data (samples (floor start) fftlen)))
(autocorrelate data)
(set! autolen 0)
(let ((happy #f))
@@ -143,16 +141,14 @@
(set! min-i k)))))
(let ((current-mark min-i)
(current-min 0.0))
- (let* ((s0 start)
- (s1 (floor (cross-samples current-mark)))
- (len autolen)
- (sr0 (make-sampler (floor s0)))
+ (let* ((s1 (floor (cross-samples current-mark)))
+ (sr0 (make-sampler (floor start)))
(sr1 (make-sampler (floor s1)))
(ampsum (make-one-pole 1.0 -1.0))
(diffsum (make-one-pole 1.0 -1.0)))
(do ((samp0 0.0)
(i 0 (+ i 1)))
- ((= i len))
+ ((= i autolen))
(set! samp0 (next-sample sr0))
(one-pole ampsum (abs samp0))
(one-pole diffsum (abs (- (next-sample sr1) samp0))))
@@ -164,16 +160,14 @@
(do ((k (+ i 1) (+ k 1)))
((= k top))
(let ((wgt 0.0))
- (let* ((s0 start)
- (s1 (floor (cross-samples k)))
- (len autolen)
- (sr0 (make-sampler (floor s0)))
+ (let* ((s1 (floor (cross-samples k)))
+ (sr0 (make-sampler (floor start)))
(sr1 (make-sampler (floor s1)))
(ampsum (make-one-pole 1.0 -1.0))
(diffsum (make-one-pole 1.0 -1.0)))
(do ((samp0 0.0)
(i 0 (+ i 1)))
- ((= i len))
+ ((= i autolen))
(set! samp0 (next-sample sr0))
(one-pole ampsum (abs samp0))
(one-pole diffsum (abs (- (next-sample sr1) samp0))))
diff --git a/s7-slib-init.scm b/s7-slib-init.scm
index f6a7ec7..ddfa3f5 100644
--- a/s7-slib-init.scm
+++ b/s7-slib-init.scm
@@ -18,7 +18,7 @@
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
- "http://ccrma.stanford.edu/software/snd/")
+ (copy "http://ccrma.stanford.edu/software/snd/"))
;;@ (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
@@ -35,7 +35,7 @@
((vms) "scheme$src:")
((ms-dos) "C:\\Program Files\\snd\\")
(else "")))))
- (lambda () impl-path)))
+ (lambda () (copy impl-path))))
;;@ (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
@@ -51,7 +51,7 @@
((vms) "lib$scheme:")
((ms-dos) "C:\\Program Files\\slib\\")
(else "")))))
- (lambda () library-path)))
+ (lambda () (copy library-path))))
;;@ (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
@@ -67,7 +67,7 @@
;@
(define (user-vicinity)
- (if (eq? (software-type) 'vms) "[.]" ""))
+ (copy (if (eq? (software-type) 'vms) "[.]" "")))
(define *load-pathname* #f) ; *load-path* is a list of dirs in s7
@@ -303,8 +303,7 @@
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
- (string->symbol
- (string-append "slib:G" (number->string *gensym-counter*))))))
+ (symbol "slib:G" (number->string *gensym-counter*)))))
(define base:eval slib:eval)
;@
diff --git a/s7.c b/s7.c
index c9b2d26..5cfa7ec 100644
--- a/s7.c
+++ b/s7.c
@@ -317,9 +317,11 @@
#include <complex>
#else
#include <complex.h>
- #if defined(__sun) && defined(__SVR4)
- #undef _Complex_I
- #define _Complex_I 1.0fi
+ #ifndef __SUNPRO_C
+ #if defined(__sun) && defined(__SVR4)
+ #undef _Complex_I
+ #define _Complex_I 1.0fi
+ #endif
#endif
#endif
#ifndef CMPLX
@@ -2644,7 +2646,7 @@ enum {OP_NO_OP,
OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_UNCHECKED, OP_BEGIN1,
OP_IF, OP_IF1, OP_WHEN, OP_WHEN1, OP_UNLESS, OP_UNLESS1, OP_SET, OP_SET1, OP_SET2,
OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2,
- OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, OP_COND, OP_COND1, OP_COND_SIMPLE, OP_COND1_SIMPLE,
+ OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, OP_COND, OP_COND1, OP_COND1_1, OP_COND_SIMPLE, OP_COND1_SIMPLE,
OP_AND, OP_AND1, OP_OR, OP_OR1,
OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION,
OP_CASE, OP_CASE1, OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE,
@@ -2824,7 +2826,7 @@ static const char *op_names[OP_MAX_DEFINED_1] = {
"define", "define1", "begin", "begin_unchecked", "begin1",
"if", "if1", "when", "when1", "unless", "unless1", "set", "set1", "set2",
"let", "let1", "let_star", "let_star1", "let_star2",
- "letrec", "letrec1", "letrec_star", "letrec_star1", "cond", "cond1", "cond_simple", "cond1_simple",
+ "letrec", "letrec1", "letrec_star", "letrec_star1", "cond", "cond1", "cond1_1", "cond_simple", "cond1_simple",
"and", "and1", "or", "or1",
"define_macro", "define_macro_star", "define_expansion",
"case", "case1", "read_list", "read_next", "read_dot", "read_quote",
@@ -5500,11 +5502,14 @@ static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args)
}
+static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args);
static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args)
{
- #define H_symbol "(symbol str) returns the string str converted to a symbol"
- #define Q_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol)
- return(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol));
+ #define H_symbol "(symbol str ...) returns its string arguments concatenated and converted to a symbol"
+ #define Q_symbol s7_make_circular_signature(sc, 1, 2, sc->is_symbol_symbol, sc->is_string_symbol)
+ if (is_null(cdr(args)))
+ return(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol));
+ return(g_string_to_symbol_1(sc, g_string_append(sc, args), sc->symbol_symbol));
}
@@ -6102,6 +6107,7 @@ static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args)
#define H_varlet "(varlet env ...) adds its arguments (an environment, a cons: symbol . value, or a pair of arguments, the symbol and its value) \
to the environment env, and returns the environment."
#define Q_varlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->T)
+ /* varlet = with-let + define */
s7_pointer x, e, sym, val, p;
@@ -6466,6 +6472,18 @@ static s7_pointer let_ref_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
if (has_ref_fallback(env))
check_method(sc, env, sc->let_ref_fallback_symbol, sc->w = list_2(sc, env, symbol));
+ /* why did this ignore a global value? Changed 24-May-16 to check rootlet if no methods --
+ * apparently I was using #<undefined> here (pre-rootlet-check) to indicate that an
+ * open let did not have a particular method (locally). This seems inconsistent now,
+ * but it was far worse before. At least (let () ((curlet) 'pi)) is pi!
+ */
+ if (!has_methods(env))
+ {
+ y = global_slot(symbol);
+ if (is_slot(y))
+ return(slot_value(y));
+ }
+
return(sc->undefined);
}
@@ -6511,7 +6529,7 @@ static s7_pointer call_accessor(s7_scheme *sc, s7_pointer slot, s7_pointer old_v
{
s7_pointer func, new_value;
- new_value = sc->error_symbol;
+ /* new_value = sc->error_symbol; */
func = slot_accessor(slot);
if (is_procedure_or_macro(func))
@@ -6572,6 +6590,18 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7
if (has_set_fallback(env))
check_method(sc, env, sc->let_set_fallback_symbol, sc->w = list_3(sc, env, symbol, value));
+
+ if (!has_methods(env))
+ {
+ y = global_slot(symbol);
+ if (is_slot(y))
+ {
+ if (slot_has_accessor(y))
+ slot_set_value(y, call_accessor(sc, y, value));
+ else slot_set_value(y, value);
+ return(slot_value(y));
+ }
+ }
return(sc->undefined);
}
@@ -6940,6 +6970,7 @@ static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args)
#define H_symbol_to_value "(symbol->value sym (env (curlet))) returns the binding of (the value associated with) the \
symbol sym in the given environment: (let ((x 32)) (symbol->value 'x)) -> 32"
#define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol)
+ /* (symbol->value 'x e) => (e 'x)? */
s7_pointer sym;
sym = car(args);
@@ -33637,6 +33668,23 @@ static s7_pointer permanent_list(s7_scheme *sc, int len)
static int sigs = 0, sig_pairs = 0;
#endif
+static void check_sig_entry(s7_scheme *sc, s7_pointer p, s7_pointer res, bool circle)
+{
+ if ((!is_symbol(car(p))) &&
+ (!s7_is_boolean(car(p))) &&
+ (!is_pair(car(p))))
+ {
+ s7_pointer np;
+ int i;
+ for (np = res, i = 0; np != p; np = cdr(np), i++);
+ fprintf(stderr, "s7_make_%ssignature got an invalid entry at position %d: (", (circle) ? "circular_" : "", i);
+ for (np = res; np != p; np = cdr(np))
+ fprintf(stderr, "%s ", DISPLAY(car(np)));
+ fprintf(stderr, "...");
+ car(p) = sc->nil;
+ }
+}
+
s7_pointer s7_make_signature(s7_scheme *sc, int len, ...)
{
va_list ap;
@@ -33651,13 +33699,7 @@ s7_pointer s7_make_signature(s7_scheme *sc, int len, ...)
for (p = res; is_pair(p); p = cdr(p))
{
car(p) = va_arg(ap, s7_pointer);
-#if DEBUGGING
- if (!car(p))
- {
- fprintf(stderr, "missed type check in procedure-signature\n");
- abort();
- }
-#endif
+ check_sig_entry(sc, p, res, false);
}
va_end(ap);
@@ -33679,18 +33721,14 @@ s7_pointer s7_make_circular_signature(s7_scheme *sc, int cycle_point, int len, .
for (p = res, i = 0; is_pair(p); p = cdr(p), i++)
{
car(p) = va_arg(ap, s7_pointer);
+ check_sig_entry(sc, p, res, true);
if (i == cycle_point) back = p;
if (i == (len - 1)) end = p;
-#if DEBUGGING
- if (!car(p))
- {
- fprintf(stderr, "missed type check in (circular) procedure-signature\n");
- abort();
- }
-#endif
}
va_end(ap);
- cdr(end) = back;
+ if (end) cdr(end) = back;
+ if (i < len)
+ fprintf(stderr, "s7_make_circular_signature got too few entries: %s\n", DISPLAY(res));
return((s7_pointer)res);
}
@@ -38152,12 +38190,11 @@ PIPF_TO_PF(vector_set, c_vector_set_s, c_vector_set_3, c_vector_tester)
static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args)
{
- #define H_make_vector "(make-vector len (value #f) (homogeneous #f)) returns a vector of len elements initialized to value. \
+ #define H_make_vector "(make-vector len (value #<unspecified>)) returns a vector of len elements initialized to value. \
To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \
(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \
-returns a 2 dimensional vector of 6 total elements, all initialized to 1.0. If homogeneous is #t, and value is either an integer \
-or a real, the vector can only hold numbers of that type (s7_int or s7_double)."
- #define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, sc->is_boolean_symbol)
+returns a 2 dimensional vector of 6 total elements, all initialized to 1.0."
+ #define Q_make_vector s7_make_signature(sc, 3, sc->is_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T)
s7_int len;
s7_pointer x, fill, vec;
@@ -39180,16 +39217,10 @@ static bool c_function_is_ok(s7_scheme *sc, s7_pointer x)
* I guess ideally eval would ignore optimization info -- copy :readable or something.
*/
return((p == opt_any1(x)) ||
- ((is_any_c_function(p)) && (opt_cfunc(x)) &&
+ ((is_any_c_function(p)) && /* (opt_cfunc(x)) && */
(c_function_class(p) == c_function_class(opt_cfunc(x)))));
}
-#if 0
-#define c_function_is_ok(Sc, X) \
- ({ s7_pointer _X_, _p_; _X_ = X; _p_ = find_global_symbol_checked(Sc, car(_X_)); \
- ((_p_ == opt_cfunc(_X_)) || ((is_any_c_function(_p_)) && (c_function_class(_p_) == c_function_class(opt_cfunc(_X_))))); })
-#endif
-
static bool arglist_has_rest(s7_scheme *sc, s7_pointer args)
{
s7_pointer p;
@@ -40497,9 +40528,6 @@ static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, s7_poi
y->next = x->next;
break;
}
-#if DEBUGGING
- if (!x) fprintf(stderr, "lost %s!\n", DISPLAY(key));
-#endif
}
hash_table_entries(table)--;
if ((hash_table_entries(table) == 0) &&
@@ -40854,7 +40882,7 @@ s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key)
static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args)
{
#define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table"
- #define Q_hash_table_ref s7_make_signature(sc, 3, sc->T, sc->is_hash_table_symbol, sc->T)
+ #define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T)
s7_pointer table;
table = car(args);
@@ -43938,7 +43966,11 @@ static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_
s7_pointer s7_copy(s7_scheme *sc, s7_pointer args)
{
#define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end."
- #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol)
+ /* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */
+ /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence,
+ * but it can provide a copy method. So, I think I'll just use #t
+ */
+ #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol)
s7_pointer source, dest;
s7_int i, j, dest_len, start, end, source_len;
@@ -46910,6 +46942,29 @@ static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, unsigned int line)
return(tree_descend(sc, cdr(p), line));
}
+static char *current_input_string(s7_scheme *sc, s7_pointer pt)
+{
+ /* try to show the current input */
+ if ((is_input_port(pt)) &&
+ (!port_is_closed(pt)) &&
+ (port_data(pt)) &&
+ (port_position(pt) > 0))
+ {
+ const unsigned char *str;
+ char *msg;
+ int i, j, start;
+ start = (int)port_position(pt) - 40;
+ if (start < 0) start = 0;
+ msg = (char *)malloc(64 * sizeof(char));
+ str = (const unsigned char *)port_data(pt);
+ for (i = start, j = 0; i < (int)port_position(pt); i++, j++)
+ msg[j] = str[i];
+ msg[j] = '\0';
+ return(msg);
+ }
+ return(NULL);
+}
+
static s7_pointer missing_close_paren_error(s7_scheme *sc)
{
@@ -46983,24 +47038,14 @@ static s7_pointer missing_close_paren_error(s7_scheme *sc)
return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
}
- /* try to show the current input */
- if ((is_input_port(pt)) &&
- (!port_is_closed(pt)) &&
- (port_data(pt)) &&
- (port_position(pt) > 0))
- {
- const unsigned char *str;
- int i, j, start;
- start = (int)port_position(pt) - 40;
- if (start < 0) start = 0;
- msg = (char *)malloc(128 * sizeof(char));
- len = snprintf(msg, 128, "missing close paren: ");
- str = (const unsigned char *)port_data(pt);
- for (i = start, j = len; i < (int)port_position(pt); i++, j++)
- msg[j] = str[i];
- msg[j] = '\0';
- return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, j))));
- }
+ {
+ char *str;
+ msg = (char *)malloc(128 * sizeof(char));
+ str = current_input_string(sc, pt);
+ len = snprintf(msg, 128, "missing close paren: %s", str);
+ free(str);
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ }
return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "missing close paren"))));
}
@@ -47074,8 +47119,7 @@ static bool call_begin_hook(s7_scheme *sc)
return(false);
}
-
-static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d)
+static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d)
{
s7_pointer p, q;
/* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */
@@ -47083,14 +47127,15 @@ static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d)
q = p;
while (is_not_null(cdr(cdr(p))))
{
- d = cons(sc, car(p), cdr(p));
- p = cdr(p);
+ d = cdr(d);
+ cdr(p) = cons(sc, car(d), cdr(d));
+ if (is_not_null(cdr(d)))
+ p = cdr(p);
}
cdr(p) = car(cdr(p));
return(q);
}
-
static s7_pointer apply_list_error(s7_scheme *sc, s7_pointer lst)
{
return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "apply's last argument should be a proper list: ~S"), lst)));
@@ -48417,7 +48462,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
iter_list = sc->z;
old_args = sc->args;
func = c_function_call(f);
- push_stack(sc, OP_NO_OP, iter_list, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection */
+ push_stack(sc, OP_NO_OP, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */
sc->z = sc->nil;
while (true)
@@ -49175,6 +49220,7 @@ static token_t read_comma(s7_scheme *sc, s7_pointer pt)
sc->strbuf[0] = ','; /* was '@' which doesn't make any sense */
return(TOKEN_COMMA); /* was TOKEN_ATOM, which also doesn't seem sensible */
}
+
backchar(c, pt);
return(TOKEN_COMMA);
}
@@ -49484,6 +49530,32 @@ static s7_pointer read_expression(s7_scheme *sc)
case TOKEN_COMMA:
push_stack_no_code(sc, OP_READ_UNQUOTE, sc->nil);
sc->tok = token(sc);
+ switch (sc->tok)
+ {
+ case TOKEN_EOF:
+ pop_stack(sc);
+ return(read_error(sc, "stray comma at the end of the input?"));
+
+ case TOKEN_RIGHT_PAREN:
+ pop_stack(sc);
+ {
+ char *str;
+ str = current_input_string(sc, sc->input_port);
+ if (str)
+ {
+ char *msg;
+ int len;
+ msg = (char *)malloc(128 * sizeof(char));
+ len = snprintf(msg, 128, "at \"...%s...\", stray comma before ')'?", str);
+ free (str);
+ return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
+ }
+ return(read_error(sc, "stray comma before ')'?")); /* '("a" "b",) */
+ }
+
+ default:
+ break;
+ }
break;
case TOKEN_AT_MARK:
@@ -53591,7 +53663,7 @@ static bool optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
}
/* not c func */
- if(is_closure(func))
+ if (is_closure(func))
{
if (closure_arity_to_int(sc, func) != 3)
return(false);
@@ -56185,7 +56257,7 @@ static int expansion_ex(s7_scheme *sc)
* (define (ex1 b) (* b 2)) (display (ex1 3))
* since this happens at the top level, the first line is evaluated, ex1 becomes an expansion.
* but the reader has no idea about lets and whatnot, so in the second line, ex1 is still an expansion
- * to the reader, so ir sees (define (+ b 1) ...) -- error! To support tail-calls, there's no
+ * to the reader, so it sees (define (+ b 1) ...) -- error! To support tail-calls, there's no
* way in eval to see the let close, so we can't clear the expansion flag when the let is done.
* But we don't want define-expansion to mimic define-constant (via T_IMMUTABLE) because programs
* like lint need to cancel reader-cond (for example). So, we allow an expansion to be redefined,
@@ -56196,6 +56268,11 @@ static int expansion_ex(s7_scheme *sc)
* then (define (ex1 b) b).
*
* This is a mess! Maybe we should insist that expansions are always global.
+ *
+ * run-time expansion and splicing into the code as in CL won't work in s7 because macros
+ * are first-class objects. For example (define (f m) (m 1)), call it with a macro, say `(+ ,arg 1),
+ * and in CL-style, you'd now have the body (+ ,arg 1) or maybe even 2, now call f with a function,
+ * or some other macro -- oops!
*/
loc = s7_stack_top(sc) - 1;
@@ -64613,7 +64690,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
* we get here over and over. (let ((x (list (car y))))...) where list is redefined away.
*/
#if DEBUGGING
- if (is_h_optimized(sc->code))
+ /* we hit this in zauto (cdr-constants ...) h_vector_s|c (there is no difference here between hop_ and op_)
+ */
+ if ((is_h_optimized(sc->code)) &&
+ (optimize_op(sc->code) != HOP_VECTOR_C) &&
+ (optimize_op(sc->code) != HOP_VECTOR_S))
fprintf(stderr, "%s[%d]: clearing %s in %s\n", __func__, __LINE__, opt_names[optimize_op(sc->code)], DISPLAY(sc->code));
#endif
clear_all_optimizations(sc, code);
@@ -66603,6 +66684,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
* which means that (letrec ((x x)) x) is not an error!
* but this assumes the environment is not changed by evaluating the exprs?
* (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling env, not the current env
+ * (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2)
+ *
* I think I need to check here that slot_pending_value is set (using the is_checked bit below).
*/
sc->envir = new_frame_in_env(sc, sc->envir);
@@ -66733,10 +66816,37 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if ((car(sc->code) == sc->feed_to_symbol) &&
(s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
{
+ /* old form (pre 6-June-16): this causes a double evaluation:
+ * (let ((x 'y) (y 32)) (cond ((values x y) => list))) -> '(32 32)
+ * but it should be '(y 32)
+ * it's also extremely slow: make/eval a list?!
+ *
+ * if (is_multiple_value(sc->value))
+ * sc->code = cons(sc, cadr(sc->code), multiple_value(sc->value));
+ * else sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->quote_symbol, sc->value));
+ * goto EVAL;
+ */
if (is_multiple_value(sc->value)) /* (cond ((values 1 2) => +)) */
- sc->code = cons(sc, cadr(sc->code), multiple_value(sc->value));
- else sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->quote_symbol, sc->value));
- goto EVAL;
+ {
+ sc->args = multiple_value(sc->value);
+ clear_multiple_value(sc->args);
+ }
+ else sc->args = list_1(sc, sc->value);
+ if (is_symbol(cadr(sc->code)))
+ {
+ sc->code = find_symbol_checked(sc, cadr(sc->code)); /* car is => */
+ if (needs_copied_args(sc->code))
+ sc->args = copy_list(sc, sc->args);
+ goto APPLY;
+ }
+ else
+ {
+ /* need to evaluate the target function */
+ push_stack(sc, OP_COND1_1, sc->args, sc->code);
+ sc->code = cadr(sc->code);
+ sc->args = sc->nil;
+ goto EVAL;
+ }
}
goto BEGIN1;
}
@@ -66755,7 +66865,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
push_stack_no_args(sc, OP_COND1, sc->code);
sc->code = caar(sc->code);
goto EVAL;
-
+
+ case OP_COND1_1:
+ sc->code = sc->value;
+ if (needs_copied_args(sc->code))
+ sc->args = copy_list(sc, sc->args);
+ goto APPLY;
case OP_COND_SIMPLE:
push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code);
@@ -72747,7 +72862,8 @@ static s7_int tree_len(s7_scheme *sc, s7_pointer p, s7_int i)
{
if (is_null(p))
return(i);
- if (!is_pair(p))
+ if ((!is_pair(p)) ||
+ (car(p) == sc->quote_symbol))
return(i + 1);
return(tree_len(sc, car(p), tree_len(sc, cdr(p), i)));
}
@@ -73494,7 +73610,7 @@ s7_scheme *s7_init(void)
defun("symbol-table", symbol_table, 0, 0, false);
sc->symbol_to_string_symbol = defun("symbol->string", symbol_to_string, 1, 0, false);
sc->string_to_symbol_symbol = defun("string->symbol", string_to_symbol, 1, 0, false);
- sc->symbol_symbol = defun("symbol", symbol, 1, 0, false);
+ sc->symbol_symbol = defun("symbol", symbol, 1, 0, true);
sc->symbol_to_value_symbol = defun("symbol->value", symbol_to_value, 1, 1, false);
sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false);
s7_typed_dilambda(sc, "symbol-access", g_symbol_access, 1, 1, g_symbol_set_access, 2, 1, H_symbol_access, Q_symbol_access, NULL);
@@ -73802,7 +73918,7 @@ s7_scheme *s7_init(void)
sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true);
sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true);
sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false);
- sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false);
+ sc->make_vector_symbol = defun("make-vector", make_vector, 1, 1, false);
sc->make_shared_vector_symbol = defun("make-shared-vector", make_shared_vector, 2, 1, false);
sc->vector_symbol = defun("vector", vector, 0, 0, true);
set_setter(sc->vector_symbol); /* like cons, I guess */
@@ -74022,6 +74138,9 @@ s7_scheme *s7_init(void)
#if defined(__sun) && defined(__SVR4)
s7_provide(sc, "solaris");
#endif
+#ifdef __SUNPRO_C
+ s7_provide(sc, "sunpro_c");
+#endif
sc->vector_set_function = slot_value(global_slot(sc->vector_set_symbol));
@@ -74182,7 +74301,7 @@ s7_scheme *s7_init(void)
(values))))");
s7_eval_c_string(sc, "(define make-hook \n\
- (let ((signature '(procedure? #t)) \n\
+ (let ((signature '(procedure?)) \n\
(documentation \"(make-hook . pars) returns a new hook (a function) that passes the parameters to its function list.\")) \n\
(lambda args \n\
(let ((body ())) \n\
@@ -74320,7 +74439,7 @@ int main(int argc, char **argv)
/* --------------------------------------------------------------------
*
- * 12 | 13 | 14 | 15 | 16.0 16.1 16.2 16.6
+ * 12 | 13 | 14 | 15 | 16.0 16.1 16.2 16.7
*
* s7test 1721 | 1358 | 995 | 1194 | 1122 1117 1295
* index 44.3 | 3291 | 1725 | 1276 | 1156 1158 1159
@@ -74344,30 +74463,15 @@ int main(int argc, char **argv)
*
* mockery.scm needs documentation (and stuff.scm: doc cyclic-seq+stuff under circular lists)
* cyclic-seq in stuff.scm, but current code is really clumsy
- * gtk gl: I can't see how to switch gl in and out as in the motif version -- I guess I need both gl_area and drawing_area
- * the old mus-audio-* code needs to use play or something, especially bess* -- what about soundio
- * snd namespaces from <mark> etc mark: (inlet :type 'mark :name "" :home <channel> :sample 0 :sync #f) with name/sync/sample settable
* doc c_object_rf stuff? or how cload ties things into rf/sig
* libutf8proc.scm doc/examples? cload gtk/sndlib
* display of let can still get into infinite recursion!
- * when trying to display a big 128-channel file, Snd cores up until it crashes?
- * check stdin-prompt and s7webserver
* (> (length x) 1) and friends could be optimized by quitting as soon as possible
* doc (set! (with-let...) ...) and let-temporarily? this could also be greatly optimized
* with-let and unlet don't need to be constants
- * (define-macro (import e) `(#_varlet (#_curlet) ,e)) or something like that?
- *
- * clm make-* sig should include the actual gen: oscil->(float? oscil? real?), also make->actual not #t in a circle
- * make-oscil -> '(oscil? real? real)
- * make-env -> '(env? sequence? real? real? real? real? integer? integer?) [seq here is actually pair? or float-vector?]
- * need some semi-automated approach here
- * also need rest of Snd signatures
- *
- * dac loop [need start/end of loop in dac_info, reader goes to start when end reached (requires rebuffering)
- * looper does not stop/restart -- just keep going]
- * play_selection_1 could puts ends somewhere, set ends to NO_END_SPECIFIED, dac_loop_sample can
- * use begs/other-ends to get loop points, so free_dac_info does not need to restart the loop(?)
- * If start/end selection changed while playing, are these loop points updated?
+ * float_format_g -> (*s7* 'default-float-format) ? -- best would be translation from format -> fprint, but ".*g" currently
+ * let-lambda(*) -- first arg is let, rest are let vars being set, then body with-let
+ * this could be a macro, but better built-in (generators)
*
* how to get at read-error cause in catch? port-data=string, port-position=int, port_data_size=int last-open-paren (sc->current_line)
* port-data port-position, length=remaining (unread) chars, copy->string gets that data, so no need for new funcs
@@ -74380,4 +74484,19 @@ int main(int argc, char **argv)
* (append "asd" ((*mock-char* 'mock-char) #\g)): error: append argument 1, #\g, is mock-char but should be a sequence
* also arg num is incorrect -- always off by 1?
* append in string case uses string_append, not g_string_append!
+ *
+ * Snd:
+ * dac loop [need start/end of loop in dac_info, reader goes to start when end reached (requires rebuffering)
+ * looper does not stop/restart -- just keep going]
+ * play_selection_1 could puts ends somewhere, set ends to NO_END_SPECIFIED, dac_loop_sample can
+ * use begs/other-ends to get loop points, so free_dac_info does not need to restart the loop(?)
+ * If start/end selection changed while playing, are these loop points updated?
+ *
+ * check stdin-prompt and s7webserver
+ * gtk gl: I can't see how to switch gl in and out as in the motif version -- I guess I need both gl_area and drawing_area
+ * the old mus-audio-* code needs to use play or something, especially bess* -- what about soundio
+ * snd namespaces from <mark> etc mark: (inlet :type 'mark :name "" :home <channel> :sample 0 :sync #f) with name/sync/sample settable
+ * when trying to display a big 128-channel file, Snd cores up until it crashes?
+ * musglyphs gtk version is broken (probably cairo_t confusion)
+ * snd+gtk+script->eps fails?? Also why not make a graph in the no-gui case here? t415.scm.
*/
diff --git a/s7.h b/s7.h
index e4b09c8..a2a7f1d 100644
--- a/s7.h
+++ b/s7.h
@@ -1,8 +1,8 @@
#ifndef S7_H
#define S7_H
-#define S7_VERSION "4.6"
-#define S7_DATE "20-Feb-16"
+#define S7_VERSION "4.8"
+#define S7_DATE "30-May-16"
typedef long long int s7_int; /* This sets the size of integers in Scheme; it needs to be big enough to accomodate a C pointer. */
typedef double s7_double; /* similarly for Scheme reals; only "double" works in C++ */
@@ -775,6 +775,8 @@ s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args,
*
* s7 changes
*
+ * 30-May: symbol takes any number of args. make-vector no longer takes an optional fourth argument.
+ * 24-May: let-ref/set! check rootlet now if let is not an open let; setter for with-let.
* 20-Feb: removed last vestiges of quasiquoted vector support.
* 3-Feb: *cload-directory*.
* 14-Jan: profile.scm. Moved multiple-value-set! to stuff.scm. Setter for port-line-number.
diff --git a/s7.html b/s7.html
index 2c30a06..d6c1c1b 100644
--- a/s7.html
+++ b/s7.html
@@ -1376,45 +1376,6 @@ to be evaluated in its definition environment:
-->
-<details>
-<summary class="indented">loopy macros</summary>
-<div class="indented">
-
-<p>There is another problem with macros: accidental loops. Take the following
-example; we're trying to write a macro that defines a function
-that returns its argument in a list statement.
-</p>
-
-<pre class="indented">
-> (define-macro (hang arg) `(define ,arg `(list (cdr ,,arg))))
-<em class="gray">hang</em>
-> (macroexpand (hang (f a)))
-<em class="gray">(define #1=(f a) ({list} 'list ({list} 'cdr #1#)))</em>
-> (hang (f a))
-<em class="gray">f</em>
-> (procedure-source f)
-<em class="gray">(lambda #1=(a) ({list} 'list ({list} 'cdr #1#)))</em>
->(f 1)
-</pre>
-
-<p>And now we are hung — we've created a procedure with an
-infinite loop! This is surprisingly easy to do by accident.
-Here's one way out:
-</p>
-
-<pre class="indented">
-> (define-macro (hang arg) `(define ,arg `(list ,,@(cdr arg))))
-<em class="gray">hang</em>
-> (macroexpand (hang (f a)))
-<em class="gray">(define (f a) ({list} 'list a))</em>
-> (hang (f a))
-<em class="gray">f</em>
-> (f 1)
-<em class="gray">(list 1)</em>
-</pre>
-</div>
-</details>
-
<div class="indented">
@@ -1934,10 +1895,9 @@ vector-dimensions returns a list of the dimensions.
<em class="gray">#2D((1 1 1) (2 2 2) (3 3 3))</em>
</pre>
-<p>make-vector also takes an optional fourth argument. If it is #t, and the initial-value
-is either an integer or a real, make-vector produces a homogeneous vector, a vector that
-can only hold elements of the same type as the initial value (either s7_int or s7_double
-internally). Homogeneous vectors are mostly useful in conjunction with C code. These
+<p>make-int-vector and make-float-vector produce homogeneous vectors holding
+s7_ints or s7_doubles.
+These are mostly useful in conjunction with C code. These
homogeneous vector functions are currently built-in:
</p>
@@ -2599,8 +2559,7 @@ its top-level bindings are imported into the current environment:
(let ()
(load "any-library.scm" (curlet))
(map (lambda (binding)
- (cons (string->symbol
- (string-append "library:" (symbol->string (car binding))))
+ (cons (symbol "library:" (symbol->string (car binding)))
(cdr binding)))
(curlet)))))
</pre>
@@ -2664,10 +2623,6 @@ such as abs, we need to put it back to its original form:
<em class="gray">2</em>
</pre>
-<p>s7test.scm has two more versions of this idea: local-let and protected-let.
-They restore values of both global variables and outlet variables
-when the let (actually dynamic-wind) exits.
-</p>
</div>
</blockquote>
@@ -4655,6 +4610,8 @@ whatever you want! (In Snd, libc, libm, libdl, and libgdbm are automatically
tied into s7 via autoload, so if you call, for example, frexp, libm.scm
is loaded, and frexp is exported from the *libm* environment, then the
evaluator soldiers on, as if frexp had always been defined in s7).
+You can also import all of (say) gsl into the current environment
+via <code>(varlet (curlet) *libgsl*)</code>.
</p>
@@ -6010,19 +5967,17 @@ then it is part of the language, and it doesn't look like the rest of the langua
(set! (getter tree) (cdr lst))
(format *stderr* "#~D# is not defined~%" n)))))))
- (define (walk-tree tree)
+ (let walk-tree ((tree (cdr lst)))
(if (pair? tree)
(begin
(if (pair? (car tree)) (walk-tree (car tree)) (replace-sym tree car))
(if (pair? (cdr tree)) (walk-tree (cdr tree)) (replace-sym tree cdr))))
- tree)
-
- (walk-tree (cdr lst)))
+ tree))
;; str is whatever followed the #, first char is a digit
(let* ((len (length str))
(last-char (str (- len 1))))
- (and (memq last-char '(#\= #\#)) ; is it #n= or #n#?
+ (and (memv last-char '(#\= #\#)) ; is it #n= or #n#?
(let ((n (string->number (substring str 0 (- len 1)))))
(and (integer? n)
(begin
@@ -6056,7 +6011,7 @@ then it is part of the language, and it doesn't look like the rest of the langua
;; have its associated value yet. We use a symbol name that
;; string->number accepts.
(symbol->keyword
- (symbol (string-append (number->string n) (string #\null) " ")))))))
+ (symbol (number->string n) (string #\null) " "))))))
; #n<not an integer>?
))))) ; #n<something else>?
@@ -6179,7 +6134,9 @@ This output is readable, and does not eat up perfectly good
characters like vertical bar, but it means we can't easily use
variable names like "| e t c |". We could allow a name to
contain any characters if it starts and ends with "|",
-but then one vertical bar is trouble.
+but then one vertical bar is trouble. (The symbol function
+actually accepts any number of string arguments which it concatenates
+to form the new symbol name).
</p>
<p>
@@ -9293,12 +9250,31 @@ variables at the start of lint.scm to control additional output:
<pre class="indented">
-*report-unused-top-level-functions* ; if #t, report unused functions
-*report-undefined-variables* ; if #t, report undefined identifiers
-*report-shadowed-variables* ; if #t, report function parameters that are shadowed
-</pre>
-
-<p>lint is not smart about functions defined outside the current file, so *report-undefined-variables*
+*report-unused-parameters*
+*report-unused-top-level-functions*
+*report-shadowed-variables*
+*report-undefined-identifiers*
+*report-multiply-defined-top-level-functions*
+*report-nested-if*
+*report-short-branch*
+*report-one-armed-if*
+*report-loaded-files*
+*report-any-!-as-setter*
+*report-function-stuff*
+*report-doc-strings*
+*report-func-as-arg-arity-mismatch*
+*report-constant-expressions-in-do*
+*report-bad-variable-names*
+*report-built-in-functions-used-as-variables*
+*report-forward-functions*
+*report-sloppy-assoc*
+*report-bloated-arg*
+</pre>
+
+<p>See lint.scm for more about these switches. You can also extend lint by adding your own code,
+or adding your functions to lint's tables, or most simply by defining signatures for your functions.
+snd-lint.scm performs these tasks for Snd. (lint exports its innards via *lint*).
+lint is not smart about functions defined outside the current file, so *report-undefined-variables*
sometimes gets confused. You'll sometimes get a recommendation from lint that is less than helpful; nobody's perfect.
If it's actually wrong, and not just wrong-headed, please let me know.
Also in lint.scm are html-lint and C-lint. html-lint reads an HTML file looking for
diff --git a/s7test.scm b/s7test.scm
index 60ea2e4..4894dbb 100644
--- a/s7test.scm
+++ b/s7test.scm
@@ -1972,13 +1972,12 @@ void block_init(s7_scheme *sc)
(test (morally-equal? if :if) #f)
(test (morally-equal? (list 'abs 'cons) '(abs cons)) #t)
(test (morally-equal? (make-int-vector 2 0) (vector 0 0)) #t)
-(test (morally-equal? (make-vector 2 0 #t) (make-vector 2 0)) #t)
-(test (morally-equal? (make-int-vector 2 0) (make-vector 2 0 #t)) #t)
-(test (morally-equal? (make-vector 2 0 #t) (make-float-vector 2)) #t)
-(test (morally-equal? (vector 0.0 0) (make-vector 2 0.0 #t)) #t)
+(test (morally-equal? (make-int-vector 2 0) (make-vector 2 0)) #t)
+(test (morally-equal? (make-int-vector 2 0) (make-int-vector 2 0)) #t)
+(test (morally-equal? (make-int-vector 2 0) (make-float-vector 2)) #t)
+(test (morally-equal? (vector 0.0 0) (make-float-vector 2 0.0)) #t)
(test (morally-equal? (make-int-vector 2 0) (vector 0 1.0)) #f)
-(test (morally-equal? (make-vector 1 1.0 #t) (make-vector 1 1.0 #t)) #t)
-(test (morally-equal? (make-float-vector 1 -nan.0) (make-vector 1 -nan.0 #t)) #t)
+(test (morally-equal? (make-float-vector 1 -nan.0) (make-float-vector 1 -nan.0)) #t)
(test (morally-equal? (make-iterator "") (make-iterator "")) #t)
(test (morally-equal? (make-iterator "1") (make-iterator "1" (cons 1 1))) #t)
@@ -2172,8 +2171,6 @@ void block_init(s7_scheme *sc)
(test (morally-equal? (make-list 3) (make-list 3)) #t)
(test (morally-equal? (make-vector 3) (make-vector 3)) #t)
(test (morally-equal? (make-float-vector 3 1.0) (vector 1 1 1)) #t)
-(test (morally-equal? (make-vector 3 1.0 #t) (vector 1 1 1.1)) #f)
-(test (morally-equal? (make-vector 0 0.0 #t) (make-vector 0 0)) #t)
(test (morally-equal? (int-vector 1) (int-vector 2)) #f)
(test (morally-equal? (int-vector 1) (int-vector 1)) #t)
(test (morally-equal? (float-vector 0.0) (float-vector nan.0)) #f)
@@ -5634,7 +5631,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(list #\; #\, #\. #\) #\( #\" #\' #\` #\x33 #\xff #\x7f #\# #\]))
(test (symbol) 'error)
-(test (symbol "hi" "ho") 'error)
+(test (symbol "hi" "ho") 'hiho)
(let ()
(define-macro (string-case selector . clauses)
@@ -6601,8 +6598,6 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (length '((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((0))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 1)
-(test (length (make-vector 3 0 #t)) 3)
-
;;; --------------------------------------------------------------------------------
@@ -6673,8 +6668,8 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (reverse '(1 2 . 3)) '(3 2 1))
(test (reverse) 'error)
(test (reverse '(1 2 3) '(3 2 1)) 'error)
-(test (reverse (make-shared-vector (make-int-vector '(2 3) 0) '(6))) (make-vector 6 0 #t))
-(test (reverse (make-vector 6 0.0 #t)) (make-float-vector 6 0.0))
+(test (reverse (make-shared-vector (make-int-vector '(2 3) 0) '(6))) (make-int-vector 6 0))
+(test (reverse (make-float-vector 6 0.0)) (make-float-vector 6 0.0))
(for-each
(lambda (arg)
@@ -6785,7 +6780,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(let ((b (block 1 2 3 4)))
(reverse! b)
(test b (block 4 3 2 1))))
-(test (let ((v (make-vector 3 1 #t))) (set! (v 1) 2) (set! (v 2) 3) (reverse! v) v) (let ((v (make-vector 3 3 #t))) (set! (v 1) 2) (set! (v 2) 1) v))
+(test (let ((v (make-int-vector 3 1))) (set! (v 1) 2) (set! (v 2) 3) (reverse! v) v) (let ((v (make-int-vector 3 3))) (set! (v 1) 2) (set! (v 2) 1) v))
(when full-test
(let ()
@@ -8725,10 +8720,9 @@ zzy" (lambda (p) (eval (read p))))) 32)
(set! (avect i j) (cons i j))))
(set! check-shared-vector-after-gc (avect 3)))
-(test (vector? (make-vector 3 1 #t)) #t)
(if (not with-bignums)
- (test (vector? (make-vector 3 pi #t)) #t))
-(test (vector? (make-vector 3 pi #f)) #t)
+ (test (vector? (make-float-vector 3 pi)) #t))
+(test (vector? (make-vector 3 pi)) #t)
(test (vector? (make-shared-vector (make-int-vector '(2 3)) '(3 2))) #t)
@@ -8751,7 +8745,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (make-vector 3 #(hi)) #(#(hi) #(hi) #(hi)))
(test (make-vector 9/3 (list)) #(() () ()))
(test (make-vector 3/1 (make-vector 1 (make-vector 1 'hi))) #(#(#(hi)) #(#(hi)) #(#(hi))))
-(test (make-vector 0 0.0 #t) #())
+(test (make-float-vector 0 0.0) #())
(test (make-vector 0 0.0) #())
(test (let ((v (make-vector 3 0))) (set! (vector-ref v 1) 32) v) #(0 32 0))
@@ -9248,9 +9242,9 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (vector-length (vector 1 2 3 4)) 4)
(test (vector-length (let ((v (vector 1 2))) (vector-set! v 1 v) v)) 2)
(test (vector-length (let ((v (vector 1 2))) (vector-set! v 1 v) (vector-ref v 1))) 2)
-(test (vector-length (make-vector 3 0 #t)) 3)
-(if (not with-bignums) (test (vector-length (make-vector 3 pi #t)) 3))
-(if (not with-bignums) (test (vector-length (make-vector '(2 3) pi #t)) 6))
+(test (vector-length (make-int-vector 3 0)) 3)
+(if (not with-bignums) (test (vector-length (make-float-vector 3 pi)) 3))
+(if (not with-bignums) (test (vector-length (make-float-vector '(2 3) pi)) 6))
(test (vector-length) 'error)
(test (vector-length #(1) #(2)) 'error)
@@ -9279,9 +9273,9 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (vector-ref (vector-ref (vector-ref #(1 (2) #(3 (4) #(5))) 2) 2) 0) 5)
(test (let ((v (vector 1 2))) (vector-set! v 1 v) (eq? (vector-ref v 1) v)) #t)
(test (let ((v (make-int-vector 3))) (vector-ref v 1)) 0)
-(test (let ((v (make-vector 3 0 #f))) (vector-ref v 1)) 0)
+(test (let ((v (make-vector 3 0))) (vector-ref v 1)) 0)
(test (let ((v (make-float-vector 3 1.0))) (vector-ref v 1)) 1.0)
-(test (let ((v (make-vector 6 0 #t))) (vector-set! v 3 32) (let ((v1 (make-shared-vector v '(2 3)))) (vector-ref v1 1 0))) 32)
+(test (let ((v (make-int-vector 6 0))) (vector-set! v 3 32) (let ((v1 (make-shared-vector v '(2 3)))) (vector-ref v1 1 0))) 32)
(test (vector-ref) 'error)
(test (vector-ref #(1)) 'error)
@@ -9324,8 +9318,6 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (let ((v (make-vector '(2 2) 0.0 #t))) (vector-ref v 0 0 0)) 'error)
(test (let ((v (make-vector 3 0))) (v 0 0)) 'error)
(test (let ((v (make-vector '(2 2) 0))) (v 0 0 0)) 'error)
-(test (let ((v (make-vector 3 0 #t))) (vector-set! v 0 0 3)) 'error)
-(test (let ((v (make-vector '(2 2) 0 #t))) (set! (v 0 0 0) 3)) 'error)
(let ((v #(1 2 3)))
(for-each
@@ -9498,7 +9490,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (let ((v (vector #f))) (vector-set! v 0 (vector)) v) #(#()))
(test (let ((v (vector 1 (list 2) (vector 1 2 3)))) (vector-set! (vector-ref v 2) 0 21) v) #(1 (2) #(21 2 3)))
(test (let ((v (make-int-vector 3))) (vector-set! v 1 32) (vector->list v)) '(0 32 0))
-(test (let ((v (make-vector 3 0 #t))) (set! (v 1) 32) (vector->list v)) '(0 32 0))
+(test (let ((v (make-int-vector 3 0))) (set! (v 1) 32) (vector->list v)) '(0 32 0))
(test (vector-set! (vector 1 2) 0 4) 4)
(test (vector-set!) 'error)
@@ -9692,7 +9684,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(set! v (make-int-vector 1))
(vector-fill! v (bignum "2"))
(num-test (v 0) 2)
- (set! v (make-vector 3 0 #t))
+ (set! v (make-int-vector 3 0))
(vector-fill! v (bignum "2") 1 2)
(num-test (v 0) 0)
(num-test (v 1) 2)))
@@ -9709,32 +9701,31 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (let ((v (vector 1 2 3 4 5))) (vector-fill! v 21 2 3) v) #(1 2 21 4 5))
(test (let ((v (vector 1 2 3 4 5))) (vector-fill! v 21 3 3) v) #(1 2 3 4 5))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2) (vector->list v)) '(2 2 2))
-(if (not with-bignums) (test (let ((v (make-vector 3 pi #t))) (vector-fill! v 0.0) (vector->list v)) '(0.0 0.0 0.0)))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v "2.5")) 'error)
-(test (let ((v (make-vector 3 pi #t))) (vector-fill! v #\a)) 'error)
+(if (not with-bignums) (test (let ((v (make-float-vector 3 pi))) (vector-fill! v 0.0) (vector->list v)) '(0.0 0.0 0.0)))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v "2.5")) 'error)
+(test (let ((v (make-float-vector 3 pi))) (vector-fill! v #\a)) 'error)
(test (let ((v (make-float-vector 3))) (vector-fill! v 1+i) v) 'error)
-(test (let ((v (make-vector 3 0.0 #t))) (vector-fill! v 3/4) (vector->list v)) '(0.75 0.75 0.75))
-(test (let ((v (make-vector 3 0.0 #t))) (vector-fill! v 3) (vector->list v)) '(3.0 3.0 3.0))
+(test (let ((v (make-float-vector 3 0.0))) (vector-fill! v 3/4) (vector->list v)) '(0.75 0.75 0.75))
+(test (let ((v (make-float-vector 3 0.0))) (vector-fill! v 3) (vector->list v)) '(3.0 3.0 3.0))
(test (let ((v (make-int-vector 3))) (vector-fill! v 1+i) v) 'error)
-(test (let ((v (make-vector 3 0 #t))) (vector-fill! v 3/4) v) 'error)
-(test (let ((v (make-vector 3 0 #t))) (vector-fill! v 3.0) v) 'error)
-
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 1) (vector->list v)) '(1 2 2))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 1 1) (vector->list v)) '(1 1 1))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 1 2) (vector->list v)) '(1 2 1))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 1 3) (vector->list v)) '(1 2 2))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 0 3) (vector->list v)) '(2 2 2))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 1 4) (vector->list v)) 'error)
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v 2 -1) (vector->list v)) 'error)
-(test (let ((v (make-vector 3 0.0 #t))) (vector-fill! v 1.0 1) (vector->list v)) '(0.0 1.0 1.0))
-(test (let ((v (make-vector 3 1 #t))) (vector-fill! v "2.5" 1)) 'error)
-(test (let ((v (make-vector 3 pi #t))) (vector-fill! v #\a 0 1)) 'error)
-(test (let ((v (make-vector 3 0.0 #t))) (vector-fill! v 1+i 1) v) 'error)
-(test (let ((v (make-vector 3 0.0 #t))) (vector-fill! v 3/4 1) (vector->list v)) '(0.0 0.75 0.75))
+(test (let ((v (make-int-vector 3 0))) (vector-fill! v 3/4) v) 'error)
+(test (let ((v (make-int-vector 3 0))) (vector-fill! v 3.0) v) 'error)
+
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 1) (vector->list v)) '(1 2 2))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 1 1) (vector->list v)) '(1 1 1))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 1 2) (vector->list v)) '(1 2 1))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 1 3) (vector->list v)) '(1 2 2))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 0 3) (vector->list v)) '(2 2 2))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 1 4) (vector->list v)) 'error)
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v 2 -1) (vector->list v)) 'error)
+(test (let ((v (make-float-vector 3 0.0))) (vector-fill! v 1.0 1) (vector->list v)) '(0.0 1.0 1.0))
+(test (let ((v (make-int-vector 3 1))) (vector-fill! v "2.5" 1)) 'error)
+(test (let ((v (make-float-vector 3 pi))) (vector-fill! v #\a 0 1)) 'error)
+(test (let ((v (make-float-vector 3 0.0))) (vector-fill! v 1+i 1) v) 'error)
+(test (let ((v (make-float-vector 3 0.0))) (vector-fill! v 3/4 1) (vector->list v)) '(0.0 0.75 0.75))
(test (let ((v (make-float-vector 3))) (vector-fill! v 3 2) (vector->list v)) '(0.0 0.0 3.0))
-(test (let ((v (make-vector 3 0 #t))) (vector-fill! v 1+i 2) v) 'error)
-(test (let ((v (make-vector 3 0 #t))) (vector-fill! v 3/4 0 1) v) 'error)
+(test (let ((v (make-int-vector 3 0))) (vector-fill! v 1+i 2) v) 'error)
+(test (let ((v (make-int-vector 3 0))) (vector-fill! v 3/4 0 1) v) 'error)
(test (let ((v (make-int-vector 3))) (vector-fill! v 3.0 2) v) 'error)
(test (vector-fill! #() 0 "hi") 'error)
(test (vector-fill! #() 0 -1 3) 'error)
@@ -9756,10 +9747,10 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (vector-append #(1) #2d((2 3) (4 5)) #3d()) #(1 2 3 4 5))
(test (vector-append #2d((1 2) (3 4)) #3d(((5 6) (7 8)) ((9 10) (11 12)))) #(1 2 3 4 5 6 7 8 9 10 11 12))
-(test (vector-append (vector 1 2) (make-vector 1 3 #t) #(4)) #(1 2 3 4))
+(test (vector-append (vector 1 2) (make-int-vector 1 3) #(4)) #(1 2 3 4))
(test (vector-append (vector 1 2) (make-float-vector 1) #(4)) #(1 2 0.0 4))
-(test (vector->list (vector-append (make-vector 1 3 #t) (make-vector 2 1 #t))) '(3 1 1))
-(test (vector->list (vector-append (make-vector 1 0.0 #t) (make-vector 2 1.0 #t))) '(0.0 1.0 1.0))
+(test (vector->list (vector-append (make-int-vector 1 3) (make-int-vector 2 1))) '(3 1 1))
+(test (vector->list (vector-append (make-float-vector 1 0.0) (make-float-vector 2 1.0))) '(0.0 1.0 1.0))
(for-each
(lambda (arg)
@@ -9768,12 +9759,12 @@ zzy" (lambda (p) (eval (read p))))) 32)
(list "hi" #\a () 1 '(1 . 2) (cons #\a #\b) #f 'a-symbol abs _ht_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0)
3.14 3/4 1.0+1.0i #t :hi (if #f #f) (lambda (a) (+ a 1))))
-(test (equal? (make-vector 3 1) (make-vector 3 1 #t)) #f)
+(test (equal? (make-vector 3 1) (make-int-vector 3 1)) #f)
-(let ((iv (make-vector 3 1 #t))
- (fv (make-vector 3 2.0 #t))
+(let ((iv (make-int-vector 3 1))
+ (fv (make-float-vector 3 2.0))
(vv (make-vector 3 #f)))
- (test (equal? (vector-append iv iv iv) (make-vector 9 1 #t)) #t)
+ (test (equal? (vector-append iv iv iv) (make-int-vector 9 1)) #t)
(test (vector-append iv iv vv) 'error)
(test (vector-append iv fv iv) (int-vector 1 1 1 2 2 2 1 1 1))
(test (vector-append iv fv fv) (int-vector 1 1 1 2 2 2 2 2 2))
@@ -9782,7 +9773,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (vector-append fv iv iv) (float-vector 2.0 2.0 2.0 1 1 1 1 1 1)) ; #(2.0 2.0 2.0 1 1 1 1 1 1))
(test (vector-append fv iv fv) (float-vector 2.0 2.0 2.0 1 1 1 2.0 2.0 2.0)) ; #(2.0 2.0 2.0 1 1 1 2.0 2.0 2.0))
(test (vector-append fv fv iv) (float-vector 2.0 2.0 2.0 2.0 2.0 2.0 1 1 1)) ; #(2.0 2.0 2.0 2.0 2.0 2.0 1 1 1))
- (test (vector-append fv fv fv) (make-vector 9 2.0 #t))
+ (test (vector-append fv fv fv) (make-float-vector 9 2.0))
(test (vector-append fv fv vv) 'error)
(test (vector-append vv iv iv) #(#f #f #f 1 1 1 1 1 1))
(test (vector-append vv iv fv) #(#f #f #f 1 1 1 2.0 2.0 2.0))
@@ -9795,13 +9786,13 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (vector-append vv vv vv) #(#f #f #f #f #f #f #f #f #f)))
(test (equal? (vector-append (float-vector 1 2 3) #()) (float-vector 1 2 3)) #t)
-(test (equal? (vector-append (float-vector) #(1 2 3) #() (make-vector 0 0 #t)) (float-vector 1 2 3)) #t)
+(test (equal? (vector-append (float-vector) #(1 2 3) #() (make-int-vector 0 0)) (float-vector 1 2 3)) #t)
(test (equal? (float-vector) (vector-append (float-vector))) #t)
-(test (equal? (vector-append #() (float-vector) (make-vector 3 1 #t) (vector)) (make-vector 3 1)) #t)
+(test (equal? (vector-append #() (float-vector) (make-int-vector 3 1) (vector)) (make-vector 3 1)) #t)
(test (equal? (vector-append (int-vector 1 2 3) #()) (int-vector 1 2 3)) #t)
-(test (equal? (vector-append (int-vector) #(1 2 3) #() (make-vector 0 0 #t)) (int-vector 1 2 3)) #t)
+(test (equal? (vector-append (int-vector) #(1 2 3) #() (make-int-vector 0 0)) (int-vector 1 2 3)) #t)
(test (equal? (int-vector) (vector-append (int-vector))) #t)
-(test (equal? (vector-append #() (int-vector) (make-vector 3 1 #t) (vector)) (make-vector 3 1)) #t)
+(test (equal? (vector-append #() (int-vector) (make-int-vector 3 1) (vector)) (make-vector 3 1)) #t)
(when full-test
(define (test-append size)
@@ -9820,8 +9811,8 @@ zzy" (lambda (p) (eval (read p))))) 32)
(set! vecs (cons (make-vector size i) vecs))
(set! ivecs (cons (make-int-vector size i) ivecs))
(set! fvecs (cons (make-float-vector size (* i 1.0)) fvecs))
- (set! ifvecs (cons (make-vector size (if (even? i) (* i 1.0) i) #t) ifvecs))
- (set! allvecs (cons (make-vector size (if (even? i) (* i 1.0) i) (not (zero? (modulo i 3)))) allvecs))
+ (set! ifvecs (cons (make-vector size (if (even? i) (* i 1.0) i)) ifvecs))
+ (set! allvecs (cons (make-vector size (if (even? i) (* i 1.0) i)) allvecs))
(set! lsts (cons (make-list size i) lsts)))
(let ((lst (apply append lsts))
(vec (apply vector-append vecs))
@@ -9917,10 +9908,10 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (call/cc (lambda (return) (map (lambda (n) (return "oops")) (vector 1 2 3)))) "oops")
(test (call/cc (lambda (return) (map (lambda (n) (if (even? n) (return n))) (vector 1 3 8 7 9 10)))) 8)
-(test (map (lambda (x) x) (make-vector 3 0 #t)) '(0 0 0))
-(test (map (lambda (x) x) (let ((v (make-vector 3 0 #t))) (set! (v 1) 1) (set! (v 2) 2) v)) '(0 1 2))
-(test (map (lambda (x) x) (make-vector 3 0.0 #t)) '(0.0 0.0 0.0))
-(test (let ((lst ())) (for-each (lambda (n) (set! lst (cons n lst))) (let ((v (make-vector 3 0 #t))) (set! (v 1) 1) v)) lst) '(0 1 0))
+(test (map (lambda (x) x) (make-int-vector 3 0)) '(0 0 0))
+(test (map (lambda (x) x) (let ((v (make-int-vector 3 0))) (set! (v 1) 1) (set! (v 2) 2) v)) '(0 1 2))
+(test (map (lambda (x) x) (make-float-vector 3 0.0)) '(0.0 0.0 0.0))
+(test (let ((lst ())) (for-each (lambda (n) (set! lst (cons n lst))) (let ((v (make-int-vector 3 0))) (set! (v 1) 1) v)) lst) '(0 1 0))
(test (vector? (symbol-table)) #t)
@@ -9941,7 +9932,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test ((((v 0) 0) 0) 1) 2))
(test (make-vector 1 (make-vector 1 (make-vector 1 0))) #(#(#(0))))
-(test (vector->list (let ((v (make-vector 3 0 #t))) (set! (v 0) 32) (set! (v 1) -1) (set! (v 2) 2) (sort! v <))) '(-1 2 32))
+(test (vector->list (let ((v (make-int-vector 3 0))) (set! (v 0) 32) (set! (v 1) -1) (set! (v 2) 2) (sort! v <))) '(-1 2 32))
(let ((v1 (make-vector 3 1)))
(num-test (v1 1) 1)
@@ -9991,14 +9982,14 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (vector-dimensions (vector-ref #3D(((1 2 3) (3 4 5)) ((5 6 1) (7 8 2))) 0 1)) '(3))
(test (set! (vector-dimensions #(1 2)) 1) 'error)
(test (let ((v #(1 2 3))) (set! (car (vector-dimensions v)) 0) v) #(1 2 3))
-(test (vector-dimensions (make-vector '(2 3) 0 #t)) '(2 3))
+(test (vector-dimensions (make-int-vector '(2 3) 0)) '(2 3))
(let ((old-len (*s7* 'print-length)))
(let ((vect1 #3D(((1 2 3) (3 4 5)) ((5 6 1) (7 8 2))))
(vect2 #2d((1 2 3 4 5 6) (7 8 9 10 11 12)))
(vect3 #(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
(vect4 #3D(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
- (vect1t (make-vector '(2 2 3) 0 #t)))
+ (vect1t (make-int-vector '(2 2 3) 0)))
(let ((v (make-shared-vector vect1t '(12))))
(set! (v 0) 1) (set! (v 1) 2) (set! (v 2) 3) (set! (v 3) 3) (set! (v 4) 4) (set! (v 5) 5)
(set! (v 6) 5) (set! (v 7) 6) (set! (v 8) 1) (set! (v 9) 7) (set! (v 10) 8) (set! (v 11) 2))
@@ -10122,7 +10113,7 @@ zzy" (lambda (p) (eval (read p))))) 32)
(set! (*s7* 'print-length) old-len))
-(test (object->string (make-vector 3 0 #t)) "(int-vector 0 0 0)")
+(test (object->string (make-int-vector 3 0)) "(int-vector 0 0 0)")
(let ((v (make-vector '(2 2))))
(set! (v 0 0) 1)
@@ -10148,12 +10139,12 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (v 1 2 0 0) 'error)
(test (object->string v) "#2D(((0 0) (0 1) (0 2)) ((1 0) (1 1) (1 2)))"))
-(test (object->string (make-vector 3 1.0 #t)) "(float-vector 1.0 1.0 1.0)")
-(test (object->string (make-vector 3 -1.5 #t)) "(float-vector -1.5 -1.5 -1.5)")
-(test (object->string (make-vector 3 1 #t)) "(int-vector 1 1 1)")
-(test (object->string (make-vector 3 -1 #t)) "(int-vector -1 -1 -1)")
-(test (object->string (make-vector 0 0 #t)) "#()")
-(test (object->string (make-vector '(3 2 0) 0.0 #t)) "#()")
+(test (object->string (make-float-vector 3 1.0)) "(float-vector 1.0 1.0 1.0)")
+(test (object->string (make-float-vector 3 -1.5)) "(float-vector -1.5 -1.5 -1.5)")
+(test (object->string (make-int-vector 3 1)) "(int-vector 1 1 1)")
+(test (object->string (make-int-vector 3 -1)) "(int-vector -1 -1 -1)")
+(test (object->string (make-int-vector 0 0)) "#()")
+(test (object->string (make-float-vector '(3 2 0) 0.0)) "#()")
(test (let ((v1 (make-vector '(3 2) 1))
(v2 (make-vector '(3 2) 2))
@@ -10215,10 +10206,10 @@ zzy" (lambda (p) (eval (read p))))) 32)
(test (make-vector (cons 1 2) "hi") 'error)
(test (equal? (make-vector 0) (vector)) #t)
(test (equal? #() (vector)) #t)
-(test (equal? (make-vector 0 0 #t) (make-vector 0 0 #t)) #t)
-(test (equal? #() (make-vector 0 0 #t)) #t)
-(test (equal? (make-vector '(2 0)) (make-vector '(2 0) 0 #t)) #t)
-(test (equal? (make-vector '(2 0)) (make-vector '(0 2) 0 #t)) #f)
+(test (equal? (make-int-vector 0 0) (make-int-vector 0 0)) #t)
+(test (equal? #() (make-int-vector 0 0)) #t)
+(test (equal? (make-vector '(2 0)) (make-int-vector '(2 0) 0)) #t)
+(test (equal? (make-vector '(2 0)) (make-int-vector '(0 2) 0)) #f)
(let ((v (make-vector '(2 3) 0)))
(num-test (vector-length v) 6)
@@ -18436,9 +18427,9 @@ c"
(let ((v (vector 1 2 3))) (set! (v 1) v) v)
(let ((v (vector 1 #(2) 3))) (set! ((v 1) 0) v) v)
(let ((v #2d((1 2 3) (4 5 6)))) (set! (v 1 1) v) v)
- (make-vector 3 0 #t)
- (make-vector 3 0.0 #t)
- (make-vector '(2 3) 1 #t)
+ (make-int-vector 3 0)
+ (make-float-vector 3 0.0)
+ (make-int-vector '(2 3) 1)
)))
(list old-plen 8 2 1))
(set! (*s7* 'print-length) old-plen))
@@ -19502,7 +19493,7 @@ c"
(test sum 14))
-(define (and-map func . args)
+(define (and-map func . args) ; see stuff.scm for a better version
(call-with-exit
(lambda (quit)
(let ((result ()))
@@ -20582,7 +20573,7 @@ in s7:
(test (iterator? s1) #t)))
-(let ((str (make-vector 4 0 #t)))
+(let ((str (make-int-vector 4 0)))
(do ((i 1 (+ i 1))) ((= i 4)) (set! (str i) i))
(let ((s1 (make-iterator str)))
(test (iterator? s1) #t)
@@ -21057,6 +21048,8 @@ in s7:
(test (do () (1 2)) 2)
(test (do () '2) 2)
(test (do () (())) ())
+(test (do ((i 0 (+ i 1))) ((= i 2) (+ i j)) (define j i) j) 3) ; bizarre
+(test (do ((i 1 (+ i j))) ((>= i 2) (+ i j)) (define j i) j) 3)
(test (let ((x (do ((i 0 (+ i 1))) (#t)))) x) ()) ; guile: #<unspecified>
@@ -23403,6 +23396,7 @@ in s7:
(test (let ((f1 (define f2 32))) (+ f1 f2)) 64)
(test (let () (define x (+ (define y 3) 2)) (list x y)) '(5 3))
(test (let ((a 1) (b 2)) (define (f a b) (let ((a a) (b b)) (+ a b))) (f 4 3)) 7)
+(test (let () (define (f x . y) (if (> x 0) (f (- x 1) y) y)) (f 4 1)) '(((((1))))))
;;; --------
;;; check envs
@@ -24302,6 +24296,28 @@ in s7:
(test (string-append (values "123" "4" "5") "6" (values "78" "90")) "1234567890")
(test (+ (dynamic-wind (lambda () #f) (lambda () (values 1 2 3)) (lambda () #f)) 4) 10)
+(let ((x 'y)
+ (y 32))
+ (define (f1) (values #f))
+ (test (if (values #f) x) #<unspecified>)
+ (test (if (values #t) x) 'y)
+ (test (if (values #f) (values x)) #<unspecified>)
+ (test (if (values #t) (values x)) 'y)
+ (test (if x (values x)) 'y)
+ (test (list (values x)) '(y))
+ (test (list (values x y)) '(y 32))
+ (test (cond ((values x) => list)) '(y))
+ (test (cond ((values x y) => list)) '(y 32))
+ (test (cond ((values #f) => list)) #<unspecified>)
+ (test (cond ((values #t) => list)) '(#t))
+ (test (cond ((f1) => list)) #<unspecified>)
+ (test (list (cond ((values x)))) '(y))
+ (test (list (cond ((values x y)))) '( y 32))
+ (test (list (cond (#t (values x)))) '(y))
+ (test (list (cond (#t (values x y)))) '(y 32))
+ (test (cond ((values x) => (lambda args (apply list args)))) '(y))
+ (test (cond ((values x y) => (lambda args (apply list args)))) '(y 32)))
+
(for-each
(lambda (arg)
(test (values arg) arg))
@@ -28990,11 +29006,11 @@ who says the continuation has to restart the map from the top?
(test (sort! () #f) 'error)
(test (equal? (sort! (vector 3 4 8 2 0 1 5 9 7 6) <) (vector 0 1 2 3 4 5 6 7 8 9)) #t)
-(test (equal? (sort! (make-vector 3 0 #t) (lambda* (a b) (< a b))) (make-vector 3 0 #t)) #t)
-(test (equal? (sort! (make-vector 3 1.0 #t) >) (float-vector 1.0 1.0 1.0)) #t)
-(test (morally-equal? (let ((v (make-vector 3 0 #t))) (set! (v 1) 3) (set! (v 2) -1) (sort! v <)) #(-1 0 3)) #t)
-(test (morally-equal? (let ((v (make-vector 3 0 #t))) (set! (v 1) 3) (set! (v 2) -1) (sort! v (lambda (a b) (< a b)))) #(-1 0 3)) #t)
-(test (morally-equal? (let ((v (make-vector 3 0 #t))) (set! (v 1) 3) (set! (v 2) -1) (sort! v (lambda* (a b) (< a b)))) #(-1 0 3)) #t)
+(test (equal? (sort! (make-int-vector 3 0) (lambda* (a b) (< a b))) (make-int-vector 3 0)) #t)
+(test (equal? (sort! (make-float-vector 3 1.0) >) (float-vector 1.0 1.0 1.0)) #t)
+(test (morally-equal? (let ((v (make-int-vector 3 0))) (set! (v 1) 3) (set! (v 2) -1) (sort! v <)) #(-1 0 3)) #t)
+(test (morally-equal? (let ((v (make-int-vector 3 0))) (set! (v 1) 3) (set! (v 2) -1) (sort! v (lambda (a b) (< a b)))) #(-1 0 3)) #t)
+(test (morally-equal? (let ((v (make-int-vector 3 0))) (set! (v 1) 3) (set! (v 2) -1) (sort! v (lambda* (a b) (< a b)))) #(-1 0 3)) #t)
(test (equal? (sort! #() <) #()) #t)
(test (sort! '(1 2 . 3) <) 'error)
@@ -29074,7 +29090,7 @@ who says the continuation has to restart the map from the top?
(test (let ((v #(1 2 3))) (let ((v1 (sort! v >))) (eq? v v1))) #t)
(test (let ((v (float-vector 1 2 3))) (let ((v1 (sort! v >))) (eq? v v1))) #t)
-(test (let ((v (make-vector 3 0 #t))) (let ((v1 (sort! v >))) (eq? v v1))) #t)
+(test (let ((v (make-int-vector 3 0))) (let ((v1 (sort! v >))) (eq? v v1))) #t)
(test (let ((v #u8(0 1 2))) (let ((v1 (sort! v >))) (eq? v v1))) #t)
(test (let ((v (list 0 1 2))) (let ((v1 (sort! v >))) (eq? v v1))) #t)
(test (let ((v "012")) (let ((v1 (sort! v char>?))) (eq? v v1))) #t)
@@ -31245,7 +31261,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (arity letrec) (cons 2 *max-arity*))
(test (arity symbol->string) '(1 . 1))
(test (arity funclet) '(1 . 1))
-(test (arity make-vector) '(1 . 3))
+(test (arity make-vector) '(1 . 2))
(test (arity member) '(2 . 3))
(unless pure-s7 (test (arity string-fill!) '(2 . 4)))
(test (arity hook-functions) '(1 . 1))
@@ -31721,7 +31737,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature directory?) '(boolean? string?))
(test (procedure-signature cdar) '(#t pair?))
(test (procedure-signature hash-table-entries) '(integer? hash-table?))
-(test (procedure-signature copy) (let ((L (list #t 'sequence? 'sequence? 'integer?))) (set-cdr! (cdddr L) (cdddr L)) L))
+(test (procedure-signature copy) (let ((L (list #t #t #t 'integer?))) (set-cdr! (cdddr L) (cdddr L)) L))
(test (procedure-signature char-ci>=?) (let ((L (list 'boolean? 'char?))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature cadadr) '(#t pair?))
(test (procedure-signature openlet) (let ((L (list #t))) (set-cdr! L L) L))
@@ -31729,7 +31745,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature rootlet) '(let?))
(test (procedure-signature object->string) '(string? #t (boolean? keyword?)))
(test (procedure-signature stacktrace) '(string? integer? integer? integer? integer? boolean?))
-(test (procedure-signature make-hook) '(procedure? #t))
+(test (procedure-signature make-hook) '(procedure?))
(test (procedure-signature string-length) '(integer? string?))
(test (procedure-signature char-whitespace?) '(boolean? char?))
(test (procedure-signature random) '(number? number? random-state?))
@@ -31819,7 +31835,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature macro?) '(boolean? #t))
(test (procedure-signature inlet) (let ((L (list 'let? #t))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature procedure-setter) '(#t procedure?))
-(test (procedure-signature hash-table-ref) '(#t hash-table? #t))
+(test (procedure-signature hash-table-ref) (let ((L (list #t 'hash-table? #t))) (set-cdr! (cddr L) (cddr L)) L))
(test (procedure-signature unlet) '(let?))
(test (procedure-signature int-vector?) '(boolean? #t))
(test (procedure-signature char<?) (let ((L (list 'boolean? 'char?))) (set-cdr! (cdr L) (cdr L)) L))
@@ -31905,7 +31921,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature symbol?) '(boolean? #t))
(test (procedure-signature values) (let ((L (list 'values #t))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature integer-length) (let ((L (list 'integer?))) (set-cdr! L L) L))
-(test (procedure-signature symbol) '(symbol? string?))
+(test (procedure-signature symbol) (let ((L (list 'symbol? 'string?))) (set-cdr! (cdr L) (cdr L)) L))
(test (procedure-signature asinh) (let ((L (list 'number?))) (set-cdr! L L) L))
(test (procedure-signature pair-line-number) '(integer? pair?))
(test (procedure-signature pair-filename) '(string? pair?))
@@ -31939,7 +31955,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (procedure-signature symbol->value) '(#t symbol? let?))
(test (procedure-signature set-current-input-port) '(input-port? input-port?))
(test (procedure-signature assq) '((pair? boolean?) #t list?))
-(test (procedure-signature make-vector) '(vector? (integer? pair?) #t boolean?))
+(test (procedure-signature make-vector) '(vector? (integer? pair?) #t))
(test (procedure-signature eval) '(values #t let?))
(test (procedure-signature caddr) '(#t pair?))
(test (procedure-signature cons) '(pair? #t #t))
@@ -32077,19 +32093,27 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(let ((st (symbol-table)))
(for-each (lambda (s)
- (if (and (procedure? (symbol->value s))
- (let ((p (procedure-signature (symbol->value s))))
- (and (pair? p)
- (pair? (car p))
- (or (null? (cdar p))
- (memq #t (car p))
- (let search ((lst (car p)))
- (and (pair? lst)
- (or (memq (car lst) (cdr lst))
- (search (cdr lst)))))))))
- (format *stderr* "~A: ~A?~%" s (procedure-signature (symbol->value s)))))
+ (catch #t
+ (lambda ()
+ (let ((f (symbol->value-anywhere s)))
+ (if (procedure? f)
+ (let ((sig (procedure-signature f))
+ (ari (arity f)))
+ (when (pair? sig)
+ (if (and (pair? ari)
+ (> (cdr ari) (- (length sig) 1)))
+ (format *stderr* "~A: ~A ~A~%~%" s ari sig))
+ (when (and (pair? sig)
+ (pair? (car sig))
+ (or (null? (cdar sig))
+ (memq #t (car sig))
+ (let search ((lst (car sig)))
+ (and (pair? lst)
+ (or (memq (car lst) (cdr lst))
+ (search (cdr lst)))))))
+ (format *stderr* "~A: ~A?~%" s sig)))))))
+ (lambda args #f)))
st))
-
;;; --------------------------------------------------------------------------------
@@ -35355,7 +35379,7 @@ func
(eval `(+ x 1) (e 1)))
33)
-(test (let () ((curlet) 'abs)) #<undefined>)
+(test (let () ((curlet) 'abs)) abs) ; was #<undefined>)??
(test ((rootlet) 'abs) abs)
(test (catch #t
@@ -35405,8 +35429,6 @@ func
(let () (define (hi e) (set! (e 'a) 2)) (test (let ((a 1)) (hi (curlet)) a) 2))
(let () (define (hi) (let ((a 1)) (let ((e (curlet)) (i 'a)) (set! (e i) #\a)) a)) (hi) (hi) (test (hi) #\a))
-(test (let ((a 1)) (let ((e (curlet))) (e :hi))) #<undefined>) ; global env is not searched in this case
-
(let ((e1 #f) (e2 #f))
(let ((a 1)) (set! e1 (curlet)))
(let ((a 1)) (set! e2 (curlet)))
@@ -35518,11 +35540,11 @@ func
(test ((curlet) :y) 12)
(define f1 (let ((x 32)) (lambda (a) (+ a x))))
(test ((funclet f1) :x) 32))
-(let ((e (inlet :a 1)))
+(let ((e (inlet :aaa 1)))
(varlet e :b 2)
(test (e 'b) 2)
- (cutlet e :a)
- (test (e 'a) #<undefined>))
+ (cutlet e :aaa)
+ (test (e 'aaa) #<undefined>))
(let ((e (inlet 'a 1 'b 2 'c 3 'd 4)))
(test (object->string e) "(inlet 'a 1 'b 2 'c 3 'd 4)")
@@ -36697,9 +36719,9 @@ hi6: (string-app...
(test (copy #() "") "")
(test (copy "" #()) #())
(test (copy #() (vector 1 2 3)) #(1 2 3))
-(test (copy (make-vector 3 0.0 #t)) (make-vector 3 0.0 #t))
-(test (copy (make-vector 3 0 #t)) (make-vector 3 0 #t))
-(test (copy (make-vector '(2 3) 0 #t)) (make-vector '(2 3) 0 #t))
+(test (copy (make-float-vector 3 0.0)) (make-float-vector 3 0.0))
+(test (copy (make-int-vector 3 0)) (make-int-vector 3 0))
+(test (copy (make-int-vector '(2 3) 0)) (make-int-vector '(2 3) 0))
(test (eq? (copy 1) 1) #f)
(test (eq? (copy 1.0) 1.0) #f)
(test (eq? (copy 2/3) 2/3) #f)
@@ -36763,7 +36785,7 @@ hi6: (string-app...
(test (copy '(1 2 3) (make-vector 2) 1) #(2 3))
(test (copy #(1 2 3) (make-vector 2) 1) #(2 3))
(test (copy #(1 2 3) (make-list 2) 1) '(2 3))
-(test (copy (make-vector 3 0 #t)) (make-vector 3 0 #t))
+(test (copy (make-int-vector 3 0)) (make-int-vector 3 0))
(let ((orig "0123456789"))
(let ((iv (copy (->byte-vector orig) (make-int-vector 10))))
(test (copy iv (make-string 10)) orig)))
@@ -37020,15 +37042,15 @@ hi6: (string-app...
(format *stderr* "(copy ~A ~A ~A) -> ~A ~A?~%" s1 start end d1 d2)))
(lambda args 'error)))
(list (vector 0 0 0)
- (make-vector 2 1 #t)
- (make-vector 2 0.0 #t)
+ (make-int-vector 2 1)
+ (make-float-vector 2 0.0)
(string #\a #\b #\c #\d #\e)
(string) (list) (vector)
(if with-block (block 1.0 1.0) (float-vector 1.0 1.0))
(cons 1 2))
(list (vector 0 0 0)
- (make-vector 2 1 #t)
- (make-vector 2 0.0 #t)
+ (make-int-vector 2 1)
+ (make-float-vector 2 0.0)
(string #\a #\b #\c #\d #\e)
(string) (list) (vector)
(if with-block (block 1.0 1.0) (float-vector 1.0 1.0))
@@ -37036,14 +37058,14 @@ hi6: (string-app...
(list #f 0 1 3)))
(list #f 0 1 2)))
(list (vector 1 2 3 4)
- (let ((v (make-vector 3 0 #t))) (set! (v 0) 32) (set! (v 1) 16) (set! (v 2) 8) v)
+ (let ((v (make-int-vector 3 0))) (set! (v 0) 32) (set! (v 1) 16) (set! (v 2) 8) v)
(list 1 2 3 4 5)
(string #\a #\b)
(string) (list) (vector)
(cons 1 (cons 2 3))
(if with-block (block 1.0 2.0 3.0 4.0) (float-vector 1.0 2.0 3.0 4.0)))
(list (vector 1 2 3 4)
- (let ((v (make-vector 3 0 #t))) (set! (v 0) 32) (set! (v 1) 16) (set! (v 2) 8) v)
+ (let ((v (make-int-vector 3 0))) (set! (v 0) 32) (set! (v 1) 16) (set! (v 2) 8) v)
(list 1 2 3 4 5)
(string #\a #\b)
(string) (list) (vector)
@@ -37290,7 +37312,7 @@ hi6: (string-app...
(test (fill! (rootlet) 3) 'error)
(test (fill! (curlet) 3) 'error)
(test (fill! "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" #f) 'error)
-(let ((v (make-vector 3 0 #t))) (fill! v 32) (test v (make-vector 3 32 #t)))
+(let ((v (make-int-vector 3 0))) (fill! v 32) (test v (make-int-vector 3 32)))
(for-each
(lambda (arg)
@@ -37722,7 +37744,6 @@ hi6: (string-app...
-
;;; -------- miscellaneous amusements
(test ((number->string -1) 0) #\-)
@@ -37738,7 +37759,6 @@ hi6: (string-app...
(test (((append s7-version)) 0) #\s)
(test ((values (lambda hi #()))) #())
(test (((((lambda () (lambda () (lambda () (lambda () 1)))))))) 1)
-(test (((cond (cond => cond)) (cond)) ((cond (#t #t)))) #t)
(test ((object->string #f) (ceiling 3/4)) #\f)
(test (procedure? ((((((lambda* ((x (lambda () x))) x))))))) #t)
(test (procedure? ((((((letrec ((x (lambda () x))) x))))))) #t)
@@ -61391,6 +61411,7 @@ hi6: (string-app...
(num-test (* (tan (/ pi 9)) (tan (/ (* 2 pi) 9)) (tan (/ (* 4 pi) 9))) (sqrt 3))
(num-test (tan 0-1000i) 0-i)
(num-test (tan 0+1000i) 0+i)
+(num-test (tan (complex 0 inf.0)) 0+i)
(if with-bignums
(begin
@@ -81424,7 +81445,7 @@ etc
(define-expansion (__exp1__) (values 1 2 3))
-
+#|
(let ()
(test (abs (+ 2 -3)) (+ 1))
@@ -81483,19 +81504,7 @@ etc
(cdr f)
value-before-let))))))
(inlet in out)))))))
-#|
- (let ((abs 32)
- (a 20))
- (let ((val (local-let ()
- (set! abs 64)
- (set! a 1)
- (set! + 0)
- (define (set! a b) b)
- (format *stderr* "in local-let, abs: ~A, (- + abs): ~A~%" abs (- + abs))
- 12)))
- (format *stderr* "in outer let: abs: ~A, (+ abs): ~A, protected-let: ~A, a: ~A~%" abs (+ abs) val a)))
- (format *stderr* "top: abs: ~A, +: ~A~%" abs +)
-|#
+
(let ((abs 32)
(a 20))
(let ((val (local-let ()
@@ -81506,7 +81515,7 @@ etc
12)))
(test (+ abs a val) 64)))
(test (abs -1) (+ 1)))
-
+|#
(let ()
(define (f1) (let ((lst '(1 2 (reader-cond ((> 1 0) 3) (else 4)) 5 6))) lst))
@@ -82340,8 +82349,6 @@ etc
(test (char-ci>? ((*mock-char* 'mock-char) #\p) ((*mock-char* 'mock-char) #\m) ((*mock-char* 'mock-char) #\M) "a") 'error)
(test (char-ci>? ((*mock-char* 'mock-char) #\p) ((*mock-char* 'mock-char) #\m) ((*mock-char* 'mock-char) #\m) ((*mock-number* 'mock-number) 1)) 'error)
- (let ((v (make-vector 3 1.0 (openlet (inlet 'c #t 'make-vector (lambda args (make-vector (car args) (cadr args) ((caddr args) 'c))))))))
- (test (float-vector? v) #t))
(test (rationalize ((*mock-number* 'mock-number) 2.5) (openlet (inlet 'c 1/100 'rationalize (make-method #_rationalize (lambda (obj) (obj 'c)))))) 5/2)
(test (autoload 'asdf (openlet (inlet 'c "asdf" 'autoload (make-method #_autoload (lambda (obj) (obj 'c)))))) "asdf")
@@ -84635,7 +84642,7 @@ etc
(0 3 5) (0 4 5) (1 2 3) (1 2 4)
(1 2 5) (1 3 4) (1 3 5) (1 4 5)
(2 3 4) (2 3 5) (2 4 5) (3 4 5)))
- (iv (make-vector 3 0 #t)))
+ (iv (make-int-vector 3 0)))
(gsl_combination_init_first c)
(do ((i 0 (+ i 1)))
((= i 20))
@@ -84646,7 +84653,7 @@ etc
(gsl_combination_free c))
(let ((p (gsl_permutation_alloc 3))
- (data (make-vector 18 0 #t)))
+ (data (make-int-vector 18 0)))
(gsl_permutation_init p)
(do ((pp GSL_SUCCESS (gsl_permutation_next p))
(i 0 (+ i 3)))
@@ -85083,6 +85090,7 @@ etc
(lint-test "(+ (log x) (log 3))" "") ; oops...
(lint-test "(+ x 0 (+ 0 0))" " +: perhaps (+ x 0 (+ 0 0)) -> x")
(lint-test "(+ x #(0))" " +: in (+ x #(0)), +'s argument 2 should be a number, but #(0) is a vector?")
+ (lint-test "(+ x (if y #() 0))" " +: in (+ x (if y #() 0)), +'s argument 2 should be a number, but #() is a vector?")
(lint-test "(+ x 2.0 -2)" "")
(lint-test "(+ x (+ y z) (+ a b))" " +: perhaps (+ x (+ y z) (+ a b)) -> (+ x y z a b)")
(lint-test "(+ (- x) y)" " +: perhaps (+ (- x) y) -> (- y x)")
@@ -85145,6 +85153,9 @@ etc
(lint-test "(* (/ y z) (/ y))" " *: perhaps (* (/ y z) (/ y)) -> (/ z)")
(lint-test "(* (/ x z) (/ y w v))" " *: perhaps (* (/ x z) (/ y w v)) -> (/ (* x y) (* z w v))")
(lint-test "(* (/ x) (/ y))" " *: perhaps (* (/ x) (/ y)) -> (/ (* x y))")
+ (lint-test "(* (/ x y) z (/ y x))" " *: perhaps (* (/ x y) z (/ y x)) -> z")
+ (lint-test "(* (/ x y z) z (/ y x))" " *: perhaps (* (/ x y z) z (/ y x)) -> 1")
+ (lint-test "(* (/ x a) z (/ y x))" " *: perhaps (* (/ x a) z (/ y x)) -> (/ (* z y) a)")
(lint-test "(- 1 2)" " -: perhaps (- 1 2) -> -1")
(lint-test "(- 1 (- 1 2))" " -: perhaps (- 1 (- 1 2)) -> 2")
@@ -85203,16 +85214,38 @@ etc
(lint-test "(/ 2/3 (/ 3/2 x))" " /: perhaps (/ 2/3 (/ 3/2 x)) -> (* 4/9 x)")
; (lint-test "(/ x (* y z))" " /: perhaps (/ x (* y z)) -> (/ x y z)")
(lint-test "(/ x (/ y))" " /: perhaps (/ x (/ y)) -> (* x y)")
+ (lint-test "(/ (* x y) (* z y))" " /: perhaps (/ (* x y) (* z y)) -> (/ x z)")
+ (lint-test "(/ (* 12 (log x)) (log 2))" " /: perhaps (/ (* 12 (log x)) (log 2)) -> (* 12 (log x 2))")
+ (lint-test "(/ (* x y) (log 2))" "")
+ (lint-test "(/ (expt x y))" " /: perhaps (/ (expt x y)) -> (expt x (- y))")
+ (lint-test "(/ (expt 10 6))" " /: perhaps (/ (expt 10 6)) -> (expt 10 (- 6))")
+ (lint-test "(/ (exp x))" " /: perhaps (/ (exp x)) -> (exp (- x))")
+ (lint-test "(/ (/ x))" " /: perhaps (/ (/ x)) -> x")
+ (lint-test "(/ (/ 1 x))" " /: perhaps (/ (/ 1 x)) -> x")
+ (lint-test "(/ (/ 1 x y))" " /: perhaps (/ (/ 1 x y)) -> (* x y)")
+ (lint-test "(/ (/ z x))" " /: perhaps (/ (/ z x)) -> (/ x z)")
+ (lint-test "(/ (/ z x y))" " /: perhaps (/ (/ z x y)) -> (/ (* x y) z)")
+ (lint-test "(/ 1 (/ 1 x y))" " /: perhaps (/ 1 (/ 1 x y)) -> (* x y)")
+
+ (lint-test "(/ (exact->inexact x) 10)" " /: perhaps (/ (exact->inexact x) 10) -> (/ x 10.0)")
+ (lint-test "(+ (exact->inexact x) 10)" " +: perhaps (+ (exact->inexact x) 10) -> (+ x 10.0)")
+ (lint-test "(+ 10 (exact->inexact x))" " +: perhaps (+ 10 (exact->inexact x)) -> (+ 10.0 x)")
+ (lint-test "(* (exact->inexact x) 10)" " *: perhaps (* (exact->inexact x) 10) -> (* x 10.0)")
+ (lint-test "(* (exact->inexact x) 10 10.0)" " *: perhaps (* (exact->inexact x) 10 10.0) -> (* x 10 10.0)")
+ (lint-test "(* 10 (exact->inexact x) 10.0)" " *: perhaps (* 10 (exact->inexact x) 10.0) -> (* 10 x 10.0)")
+ (lint-test "(* 10.0 (exact->inexact x) 10.0)" " *: perhaps (* 10.0 (exact->inexact x) 10.0) -> (* 10.0 x 10.0)")
+ (lint-test "(exact->inexact (/ x 32))" " exact->inexact: perhaps (exact->inexact (/ x 32)) -> (/ x 32.0)")
+ (lint-test "(inexact (random 10))" "")
(lint-test "(sin (asin x))" " sin: perhaps (sin (asin x)) -> x")
(lint-test "(sin 0)" " sin: perhaps (sin 0) -> 0")
(lint-test "(sin pi)" " sin: perhaps (sin pi) -> 0.0")
(lint-test "(cos 0)" " cos: perhaps (cos 0) -> 1")
(lint-test "(cos (acos (+ x 1)))" " cos: perhaps (cos (acos (+ x 1))) -> (+ x 1)")
- (lint-test "(cos (* pi 1))" " cos: perhaps (cos (* pi 1)) -> 1.0")
+ (lint-test "(cos (* pi 1))" " cos: perhaps (cos (* pi 1)) -> -1.0")
(lint-test "(cos (- (* x y)))" " cos: perhaps (cos (- (* x y))) -> (cos (* x y))")
(lint-test "(cos 0)" " cos: perhaps (cos 0) -> 1")
- (lint-test "(exp (* (+ x y) (log (+ y 1))))" " exp: perhaps (exp (* (+ x y) (log (+ y 1)))) -> (expt (+ y 1) (+ x y))")
+ (lint-test "(exp (* (+ x y) (log (+ y 1))))" " exp: perhaps (exp (* (+ x y) (log (+ y 1)))) -> (expt (+ y 1) (+ x y))")
(lint-test "(exp (* (log x) a))" " exp: perhaps (exp (* (log x) a)) -> (expt x a)")
(lint-test "(exp (log (* x y)))" " exp: perhaps (exp (log (* x y))) -> (* x y)")
(lint-test "(acosh (cosh 0))" " acosh: perhaps (acosh (cosh 0)) -> (acosh 1)")
@@ -85222,6 +85255,7 @@ etc
(lint-test "(exp 0.0)" " exp: perhaps (exp 0.0) -> 1.0"))
(lint-test "(sin x 0.0)" " sin: sin has too many arguments: (sin x 0.0)")
(lint-test "(sin)" " sin: sin needs 1 argument: (sin)")
+ (lint-test "(/ (sin x) (cos x))" " /: perhaps (/ (sin x) (cos x)) -> (tan x)")
(lint-test "(log 1)" " log: perhaps (log 1) -> 0")
(lint-test "(log (exp 0))" " log: perhaps (log (exp 0)) -> 0")
@@ -85289,6 +85323,9 @@ etc
(lint-test "(denominator 3)" " denominator: perhaps (denominator 3) -> 1")
(lint-test "(denominator (round (+ x 1)))" " denominator: perhaps (denominator (round (+ x 1))) -> 1")
(lint-test "(numerator (round (+ x 1)))" " numerator: perhaps (numerator (round (+ x 1))) -> (round (+ x 1))")
+ (lint-test "(> (numerator x) 0)" " >: perhaps (> (numerator x) 0) -> (> x 0)")
+ (lint-test "(negative? (numerator x))" " negative?: perhaps (negative? (numerator x)) -> (negative? x)")
+
(lint-test "(random 0)" " random: perhaps (random 0) -> 0")
(lint-test "(random 0.0)" " random: perhaps (random 0.0) -> 0.0")
(lint-test "(random x)" "")
@@ -85370,7 +85407,7 @@ etc
(lint-test "(max 3 x 4 5)" " max: perhaps (max 3 x 4 5) -> (max 5 x)")
(lint-test "(max 3.0 x 4/5 5)" " max: perhaps (max 3.0 x 4/5 5) -> (max 5 x)")
(lint-test "(min 3.0 x 4/5 5)" " min: perhaps (min 3.0 x 4/5 5) -> (min 4/5 x)")
- (lint-test "(max 3.0 x x 5)" " max: it looks odd to have repeated arguments in (max 3.0 x x 5) max: perhaps (max 3.0 x x 5) -> (max 5 x)")
+ (lint-test "(max 3.0 x x 5)" " max: it looks odd to have repeated arguments in (max 3.0 x x 5) max: perhaps (max 3.0 x x 5) -> (max 5 x)")
(lint-test "(max 3 (max 4 x) y)" " max: perhaps (max 3 (max 4 x) y) -> (max 4 x y)")
(lint-test "(max 4 (min 3 x) y)" " max: perhaps (max 4 (min 3 x) y) -> (max 4 y)")
(lint-test "(min 4 (max 3 x) y)" "")
@@ -85381,18 +85418,31 @@ etc
(lint-test "(max (min y x) x)" " max: perhaps (max (min y x) x) -> x")
(lint-test "(max 3 (min x 3))" " max: perhaps (max 3 (min x 3)) -> 3")
(lint-test "(min x (max y z (+ 21 x) x (* y z)))" " min: perhaps (min x (max y z (+ 21 x) x (* y z))) -> x")
+ (lint-test "(max 0 (string-length x))" " max: perhaps (max 0 (string-length x)) -> (string-length x)")
+ (lint-test "(max (string-length x) -1 y)" " max: perhaps (max (string-length x) -1 y) -> (max (string-length x) y)")
(lint-test "(equal? x y z)" " equal?: equal? has too many arguments: (equal? x y z)")
(lint-test "(= 1 y 2)" " =: this comparison can't be true: (= 1 y 2)")
(lint-test "(= x 1.5)" " =: = can be troublesome with floats: (= x 1.5)")
(lint-test "(= x 0.0)" "")
- (lint-test "(= x 1.0 x)" " =: it looks odd to have repeated arguments in (= x 1.0 x)")
+ (lint-test "(= x 1.0 x)" " =: it looks odd to have repeated arguments in (= x 1.0 x)")
(lint-test "(= (- x y) 0)" " =: perhaps (= (- x y) 0) -> (= x y)")
(lint-test "(= 0.0 (- x y))" " =: perhaps (= 0.0 (- x y)) -> (= x y)")
(lint-test "(= (- (abs x) 2) 0)" " =: perhaps (= (- (abs x) 2) 0) -> (= (abs x) 2)")
(lint-test "(= (length x) 0)" " =: perhaps (assuming x is a list), (= (length x) 0) -> (null? x)")
(lint-test "(= (length x) 1)" " =: perhaps (assuming x is a list), (= (length x) 1) -> (and (pair? x) (null? (cdr x)))")
+ (lint-test "(> (- fltdur 50868) 256)" " >: perhaps (> (- fltdur 50868) 256) -> (> fltdur 51124)")
+ (lint-test "(= (- fltdur 50868) 256)" " =: perhaps (= (- fltdur 50868) 256) -> (= fltdur 51124)")
+ (lint-test "(= (- fltdur 50868) 0)" " =: perhaps (= (- fltdur 50868) 0) -> (= fltdur 50868)")
+ (lint-test "(< 256 (- fltdur 50868))" " <: perhaps (< 256 (- fltdur 50868)) -> (> fltdur 51124)")
+ (lint-test "(= 256 (- fltdur 50868))" " =: perhaps (= 256 (- fltdur 50868)) -> (= fltdur 51124)")
+ (lint-test "(> (+ fltdur 50868) 256)" " >: perhaps (> (+ fltdur 50868) 256) -> (> fltdur -50612)")
+ (lint-test "(= (+ fltdur 50868) 256)" " =: perhaps (= (+ fltdur 50868) 256) -> (= fltdur -50612)")
+ (lint-test "(= (+ fltdur 50868) 0)" " =: perhaps (= (+ fltdur 50868) 0) -> (= fltdur -50868)")
+ (lint-test "(< 256 (+ fltdur 50868))" " <: perhaps (< 256 (+ fltdur 50868)) -> (> fltdur -50612)")
+ (lint-test "(= 256 (+ fltdur 50868))" " =: perhaps (= 256 (+ fltdur 50868)) -> (= fltdur -50612)")
+
(lint-test "(zero? (- x))" " zero?: perhaps (zero? (- x)) -> (zero? x)")
(lint-test "(zero? (- x y))" " zero?: perhaps (zero? (- x y)) -> (= x y)")
(lint-test "(zero? (- x y z))" " zero?: perhaps (zero? (- x y z)) -> (= x (+ y z))")
@@ -85402,6 +85452,7 @@ etc
(lint-test "(negative? (- x))" " negative?: perhaps (negative? (- x)) -> (positive? x)")
(lint-test "(negative? (- x y))" " negative?: perhaps (negative? (- x y)) -> (< x y)")
(lint-test "(negative? (- x y z))" " negative?: perhaps (negative? (- x y z)) -> (< x (+ y z))")
+ (lint-test "(not (positive? (- n 2)))" " not: perhaps (positive? (- n 2)) -> (> n 2)")
(lint-test "(+ #e21 x)" " this #e is dumb, #e21 -> 21")
(lint-test "(+ #i1.0 x)" " this #i is dumb, #i1.0 -> 1.0")
@@ -85430,17 +85481,26 @@ etc
(lint-test "(member 1 x (lambda (a b) (> a b)))" " member: perhaps (lambda (a b) (> a b)) -> >")
(lint-test "(member 1 x (lambda (a b) (> b a)))" " member: perhaps (lambda (a b) (> b a)) -> <")
(lint-test "(member 1 x abs)" " member: abs is a questionable member function")
- (lint-test "(member x (list \"asdf\"))" " member: perhaps (member x (list \"asdf\")) -> (string=? x \"asdf\")")
+ (lint-test "(member x (list \"asdf\"))"
+ " member: perhaps (member x (list \"asdf\")) -> (string=? x \"asdf\")
+ member: perhaps (list \"asdf\") -> '(\"asdf\")")
(lint-test "(member x (list \"asd\" \"abc\" \"asd\"))"
" member: duplicated entry \"asd\" in (list \"asd\" \"abc\" \"asd\")
member: perhaps (list \"asd\" \"abc\" \"asd\") -> '(\"asd\" \"abc\" \"asd\")")
(lint-test "(memq x '(1))" " memq: perhaps (memq x '(1)) -> (= x 1)")
(lint-test "(memq x '(begin))" " memq: perhaps (memq x '(begin)) -> (eq? x 'begin)")
- (lint-test "(memq x (list 'car))" " memq: perhaps (memq x (list 'car)) -> (eq? x 'car)")
- (lint-test "(memq x '(a 'b c))" " memq: stray quote? (memq x '(a 'b c))")
- (lint-test "(memq x '(a ,b c))" " memq: stray comma? (memq x '(a (unquote b) c))")
- (lint-test "(memq x '(a (+ 1 2) 3))" " memq: pointless list member: (+ 1 2) in (memq x '(a (+ 1 2) 3))")
- (lint-test "(memq x '(a #(0)))" " memq: pointless list member: #(0) in (memq x '(a #(0)))")
+ (lint-test "(memq x (list 'car))"
+ " memq: perhaps (memq x (list 'car)) -> (eq? x 'car)
+ memq: perhaps (list 'car) -> '(car)")
+ (lint-test "(memq x '(a 'b c))" " memq: stray quote? (memq x '(a 'b c))
+ memq: memq should be member in (memq x '(a 'b c))
+ memq: pointless list member: 'b in (memq x '(a 'b c))")
+ (lint-test "(memq x '(a ,b c))" " memq: memq should be member in (memq x '(a (unquote b) c))
+ memq: stray comma? (memq x '(a (unquote b) c))")
+ (lint-test "(memq x '(a (+ 1 2) 3))" " memq: memq should be member in (memq x '(a (+ 1 2) 3))
+ memq: pointless list member: (+ 1 2) in (memq x '(a (+ 1 2) 3))")
+ (lint-test "(memq x '(a #(0)))" " memq: memq should be member in (memq x '(a #(0)))
+ memq: pointless list member: #(0) in (memq x '(a #(0)))")
(lint-test "(memv x '(#f #\\c a 1 () :a))" "")
(lint-test "(memq x '(a b a c))" " memq: duplicated entry a in '(a b a c)")
(lint-test "(assq x '((a . 1)))" "")
@@ -85460,6 +85520,45 @@ etc
(lint-test "(memv #\\= (string->list x))" " memv: perhaps (memv #\\= (string->list x)) -> (char-position #\\= x)")
(lint-test "(memv #\\= (string->list x start end))" " memv: perhaps (memv #\\= (string->list x start end)) -> (char-position #\\= x start end)")
(lint-test "(memv (string-ref s 0) (string->list x))" " memv: perhaps (memv (string-ref s 0) (string->list x)) -> (char-position (string-ref s 0) x)")
+ (lint-test "(memv (string-ref x 0) '(+ -))" " memv: memv could be memq in (memv (string-ref x 0) '(+ -))
+ memv: perhaps (memv (string-ref x 0) '(+ -)) -> #f")
+ (lint-test "(memv (string-ref x 0) '(#\\+ -))" " memv: perhaps (memv (string-ref x 0) '(#\\+ -)) -> (memv (string-ref x 0) '(#\\+))")
+ (lint-test "(memq expr '(#t #f))" " memq: perhaps (memq expr '(#t #f)) -> (boolean? expr)")
+ (lint-test "(member (denominator k/n) '(1 2 3 4 6))" " member: (member (denominator k/n) '(1 2 3 4 6)): perhaps member -> memv
+ member: member could be memv in (member (denominator k/n) '(1 2 3 4 6))")
+
+ (lint-test "(member x '(1 0))" " member: member could be memv in (member x '(1 0))")
+ (lint-test "(memq (strname 0) '(#\\{ #\\[ #\\())" " memq: memq should be memv in (memq (strname 0) '(#\\{ #\\[ #\\())")
+ (lint-test "(member (car op) '(x y z))" " member: member could be memq in (member (car op) '(x y z))")
+ (lint-test "(memv (car op) '(x y z))" " memv: memv could be memq in (memv (car op) '(x y z))")
+ (lint-test "(member (car tail) '(:x :y :z))" " member: member could be memq in (member (car tail) '(:x :y :z))")
+ (lint-test "(member x (list 1 0))" " member: member could be memv in (member x (list 1 0))
+ member: perhaps (list 1 0) -> '(1 0)")
+ (lint-test "(memq (strname 0) (list #\\{ #\\[ #\\())" " memq: memq should be memv in (memq (strname 0) (list #\\{ #\\[ #\\())
+ memq: perhaps (list #\\{ #\\[ #\\() -> '(#\\{ #\\[ #\\()")
+ (lint-test "(member (car op) (list x y z))" "")
+ (lint-test "(member (car op) (list \"a\" (f x)))" "")
+ (lint-test "(member (car op) (list \"a\" #(1)))" " member: perhaps (list \"a\" #(1)) -> '(\"a\" #(1))")
+ (lint-test "(member (car op) '(\"a\" #()))" "")
+ (lint-test "(memq (car op) '(\"a\" #()))" " memq: memq should be member in (memq (car op) '(\"a\" #()))
+ memq: pointless list member: \"a\" in (memq (car op) '(\"a\" #()))")
+ (lint-test "(member (car op) '(#f ()))" " member: member could be memq in (member (car op) '(#f ()))")
+ (lint-test "(assq c '((#\\b . 2) (#\\o . 8) (#\\d . 10)))" " assq: assq should be assv in (assq c '((#\\b . 2) (#\\o . 8) (#\\d . 10)))")
+ (lint-test "(assoc order '((1 . 1.0) (2 . 1.3)) =)" "")
+ (lint-test "(assoc order '((1 . 1.0) (2 . 1.3)))" " assoc: assoc could be assv in (assoc order '((1 . 1.0) (2 . 1.3)))")
+ (lint-test "(assq order '((1 . 1.0) (2 . 1.3)))" " assq: assq should be assv in (assq order '((1 . 1.0) (2 . 1.3)))")
+ (lint-test "(assq c (list '(#\\b . 2) '(#\\o . 8) '(#\\d . 10)))"
+ " assq: assq should be assv in (assq c (list '(#\\b . 2) '(#\\o . 8) '(#\\d . 10)))
+ assq: perhaps (list '(#\\b . 2) '(#\\o . 8) '(#\\d . 10)) -> '((#\\b . 2) (#\\o . 8) (#\\d . 10))")
+ (lint-test "(assoc order (list '(1 . 1.0) '(2 . 1.3)))" " assoc: assoc could be assv in (assoc order (list '(1 . 1.0) '(2 . 1.3)))
+ assoc: perhaps (list '(1 . 1.0) '(2 . 1.3)) -> '((1 . 1.0) (2 . 1.3))")
+ (lint-test "(assv order (list '(a . 1.0) '(b . 1.3)))" " assv: assv should be assoc in (assv order (list '(a . 1.0) '(b . 1.3)))
+ assv: perhaps (list '(a . 1.0) '(b . 1.3)) -> '((a . 1.0) (b . 1.3))")
+ (lint-test "(member (car (string->list S)) (string->list x))"
+ " member: perhaps (member (car (string->list S)) (string->list x)) -> (char-position (car (string->list S)) x)
+ member: perhaps (car (string->list S)) -> (string-ref S 0)")
+ (lint-test "(memq x '(a #<eof> #<undefined> #<unspecified>))" "")
+ (lint-test "(member x '(a #<eof> #<undefined> #<unspecified>))" " member: member could be memq in (member x '(a #<eof> #<undefined> #<unspecified>))")
(lint-test "(if #f x y)" " if: if test is never true: (if #f x y) if: perhaps (if #f x y) -> y")
(lint-test "(if #t #f)" " if: if test is never false: (if #t #f) if: perhaps (if #t #f) -> #f")
@@ -85502,9 +85601,12 @@ etc
(lint-test "(if x (set! y #f) (set! y #t))" " if: perhaps (if x (set! y #f) (set! y #t)) -> (set! y (not x))")
(lint-test "(if x (set! y x) (set! y 21))" " if: perhaps (if x (set! y x) (set! y 21)) -> (set! y (or x 21))")
(lint-test "(if x (set! y z) (set! y w))" " if: perhaps (if x (set! y z) (set! y w)) -> (set! y (if x z w))")
- (lint-test "(if x (+ y 1) (- y 1))" "") ; here we deliberately leave the function alone
+ (lint-test "(if x (+ y 1) (- y 1))" " if: perhaps (if x (+ y 1) (- y 1)) -> ((if x + -) y 1)")
(lint-test "(if x (set! y 1) (set! y (+ x 1)))" " if: perhaps (if x (set! y 1) (set! y (+ x 1))) -> (set! y (if x 1 (+ x 1)))")
(lint-test "(if x (set! y (+ x 1)) (set! y 1))" " if: perhaps (if x (set! y (+ x 1)) (set! y 1)) -> (set! y (if x (+ x 1) 1))")
+ (lint-test "(if x (or y z) (and y z))" " if: perhaps (if x (or y z) (and y z)) -> ((if x or and) y z)")
+ (lint-test "(if x (or (f y) z) (and y (f z)))" "")
+ (lint-test "(if (positive? x) (log x) (exp x))" " if: perhaps (if (positive? x) (log x) (exp x)) -> ((if (positive? x) log exp) x)")
(lint-test "(if x (if y z))" " if: perhaps (if x (if y z)) -> (if (and x y) z)")
(lint-test "(if (cadr x) (if (cadr x) 0))" " if: perhaps (if (cadr x) (if (cadr x) 0)) -> (if (cadr x) 0)")
@@ -85615,6 +85717,33 @@ etc
if: perhaps (let ((y (+ x 1)) (z (- x 1))) (+ y z)) -> (+ (+ x 1) (- x 1))
if: perhaps (let ((y (+ x 1)) (z (- x 1))) (- y z)) -> (- (+ x 1) (- x 1))")
+ (lint-test "(if (> (+ a b) 3) (let ((a x) (c y)) (* a (log c))) (let ((b z) (c y)) (+ b (log c))))"
+ "if: perhaps (if (> (+ a b) 3) (let ((a x) (c y)) (* a (log c))) (let ((b z) (c y)) (+... ->
+ (let ((c y))
+ (if (> (+ a b) 3)
+ (let ((a x))
+ (* a (log c)))
+ (let ((b z))
+ (+ b (log c)))))
+ if: perhaps (let ((a x) (c y)) (* a (log c))) -> (* x (log y))
+ if: assuming we see all set!s, (c y), (a x) are pointless: perhaps (let ((a x) (c y)) (* a (log c))) -> (let () (* x (log y)))
+ if: perhaps (let ((b z) (c y)) (+ b (log c))) -> (+ z (log y))
+ if: assuming we see all set!s, (c y), (b z) are pointless: perhaps (let ((b z) (c y)) (+ b (log c))) -> (let () (+ z (log y)))")
+
+ (lint-test "(if (> (+ a b) 3) (let ((a (+ x 1)) (c y)) (* a (log c))) (let ((a (+ x 1)) (c y)) (+ a (log c))))"
+ " if: perhaps (if (> (+ a b) 3) (let ((a (+ x 1)) (c y)) (* a (log c))) (let ((a (+ x... ->
+ (let ((_1_ (> (+ a b) 3)))
+ (let ((a (+ x 1))
+ (c y))
+ (if _1_ (* a (log c)) (+ a (log c)))))
+ if: perhaps (let ((a (+ x 1)) (c y)) (* a (log c))) -> (* (+ x 1) (log y))
+ if: assuming we see all set!s, (c y) is pointless: perhaps (let ((a (+ x 1)) (c y)) (* a (log c))) -> (let ((a (+ x 1))) (* a (log y)))
+ if: perhaps (let ((a (+ x 1)) (c y)) (+ a (log c))) -> (+ (+ x 1) (log y))
+ if: assuming we see all set!s, (c y) is pointless: perhaps (let ((a (+ x 1)) (c y)) (+ a (log c))) -> (let ((a (+ x 1))) (+ a (log y)))")
+
+ (lint-test "(let ((a (f x)) (b (g y)) (c (g z))) (h a b c))"
+ " let: perhaps (let ((a (f x)) (b (g y)) (c (g z))) (h a b c)) -> (h (f x) (g y) (g z))")
+
(lint-test "(if a (if b d e) (if c d e))" " if: perhaps (if a (if b d e) (if c d e)) -> (if (if a b c) d e)")
(lint-test "(if a (if b d) (if c d))" " if: perhaps (if a (if b d) (if c d)) -> (if (if a b c) d)")
(lint-test "(if a (if (f b) d) (if (f c) d))" " if: perhaps (if a (if (f b) d) (if (f c) d)) -> (if (if a (f b) (f c)) d)")
@@ -85660,6 +85789,17 @@ etc
" begin: this could be omitted: (if A B)
begin: perhaps (... (if A B) (if (and A C) D) ...) -> (... (if A (begin B (if C D))) ...)")
+ (lint-test "(if x (display y) (begin (set! z y) (display y)))"
+ " if: perhaps (if x (display y) (begin (set! z y) (display y))) -> (begin (if (not x) (set! z y)) (display y))")
+ (lint-test "(if x (begin (set! z y) (display y)) (display y))"
+ " if: perhaps (if x (begin (set! z y) (display y)) (display y)) -> (begin (if x (set! z y)) (display y))")
+ (lint-test "(if x (begin (display y) (set! y z)) (begin (display y) (set! z y)))"
+ " if: perhaps (if x (begin (display y) (set! y z)) (begin (display y) (set! z y))) ->
+ (begin (display y) (if x (set! y z) (set! z y)))")
+ (lint-test "(if x (begin (display y) (set! y z) (display x)) (begin (display y) (set! z y) (display x)))"
+ " if: perhaps (if x (begin (display y) (set! y z) (display x)) (begin (display y) (set!... ->
+ (begin (display y) (if x (set! y z) (set! z y)) (display x))")
+
(lint-test "(if A (if B (+ x 1)) (if B (- x 1)))"
" if: perhaps (if A (if B (+ x 1)) (if B (- x 1))) -> (if B (if A (+ x 1) (- x 1)))")
(lint-test "(if A (begin (f x) (g y)) (begin (f x) (g z)))"
@@ -85682,42 +85822,37 @@ etc
begin: this is pointless: z in (begin (display x) z)")
(lint-test "(begin (let () (display x)) y)" " begin: pointless let: (let () (display x))")
- (lint-test "(let ((list x)) (if (null? list) 3 2))" " let: perhaps (let ((list x)) (if (null? list) 3 2)) -> (if (null? x) 3 2)")
+ (lint-test "(let ((list x)) (if (null? list) 3 2))"
+ " let: perhaps (let ((list x)) (if (null? list) 3 2)) -> (if (null? x) 3 2)
+ let: assuming we see all set!s, (list x) is pointless: perhaps (let ((list x)) (if (null? list) 3 2)) -> (let () (if (null? x) 3 2))")
(lint-test "(null? (string->list x))" " null?: perhaps (null? (string->list x)) -> (zero? (length x))")
(lint-test "(memq x (if (memq y '(< <=)) '(< <=) '(> >=)))" "") ; this is checking the ->simple-type escape
(lint-test "(if q `(not ,op ,x) `(not ,op ,y))" "") ; make sure we don't try to rewrite quasiquote
- (let ((old-one *report-one-armed-if*))
- (set! *report-one-armed-if* #t)
+ (let-temporarily ((*report-one-armed-if* #t))
(lint-test "(if a (begin (set! x y) z))" " if: perhaps (if a (begin (set! x y) z)) -> (when a (set! x y) z)")
(lint-test "(if (not a) (begin (set! x y) z))" " if: perhaps (if (not a) (begin (set! x y) z)) -> (unless a (set! x y) z)")
(lint-test "(if a (set! x y))" " if: perhaps (if a (set! x y)) -> (when a (set! x y))")
- (lint-test "(if (not a) (set! x y))" " if: perhaps (if (not a) (set! x y)) -> (unless a (set! x y))")
- (set! *report-one-armed-if* old-one))
+ (lint-test "(if (not a) (set! x y))" " if: perhaps (if (not a) (set! x y)) -> (unless a (set! x y))"))
- (let ((old-doc *report-doc-strings*))
- (set! *report-doc-strings* #t)
+ (let-temporarily ((*report-doc-strings* #t))
(lint-test "(let () (define (hiho a) \"hiho is a function\" (+ a 1)) (hiho 1))"
" let: perhaps (... (define (hiho a) \"hiho is a function\" (+ a 1)) (hiho 1)) -> (... (let ((a 1)) (+ a 1)))
hiho: old-style doc string: \"hiho is a function\", in s7 use 'documentation:
(define hiho
(let ((documentation \"hiho is a function\"))
(lambda (a)
- (+ a 1))))")
- (set! *report-doc-strings* old-doc))
+ (+ a 1))))"))
- (let ((old-undef *report-undefined-identifiers*))
- (set! *report-undefined-identifiers* #t)
+ (let-temporarily ((*report-undefined-identifiers* #t))
(lint-test "(let ((x 1)) (cdr? x))" " let: perhaps (let ((x 1)) (cdr? x)) -> (cdr? 1) this identifier was not defined: cdr?")
(lint-test "(let ((x 1)) (+ x (aaa)))" " this identifier was not defined: aaa")
(lint-test "(let ((x 1)) (+ x (zzz) (aaa)))" " the following identifiers were not defined: aaa zzz")
- (set! *report-undefined-identifiers* old-undef))
+ (lint-test "(let ((example 32)) (+ exampl (* 2 example) (sqrt example)))" " this identifier was not defined: exampl"))
- (let ((old-shadow *report-shadowed-variables*))
- (set! *report-shadowed-variables* #t)
+ (let-temporarily ((*report-shadowed-variables* #t))
(lint-test "(let ((x 1)) (+ (let ((x 2)) (+ x 1)) x))"
- " let: let variable x in (x 2) shadows an earlier declaration let: perhaps (let ((x 2)) (+ x 1)) -> (+ 2 1)")
- (set! *report-shadowed-variables* old-shadow))
+ " let: let variable x in (x 2) shadows an earlier declaration let: perhaps (let ((x 2)) (+ x 1)) -> (+ 2 1)"))
(lint-test "(when (not a) (set! x y))" " when: perhaps (when (not a) (set! x y)) -> (unless a (set! x y))")
(lint-test "(unless (not a) (set! x y))" " unless: perhaps (unless (not a) (set! x y)) -> (when a (set! x y))")
@@ -85742,7 +85877,7 @@ etc
(lint-test "(cond ((< 3 1) 2))"
" cond: cond test (< 3 1) is never true: (cond ((< 3 1) 2))
cond: cond test is always false: ((< 3 1) 2)
- cond: perhaps (cond ((< 3 1) 2)) -> (cond (#f 2))")
+ cond: perhaps (cond ((< 3 1) 2)) -> (cond)")
(lint-test "(cond (else 2) (x 3))" " cond: cond else clause is not the last: (cond (else 2) (x 3))")
(lint-test "(cond (x => abs))" "")
(lint-test "(cond (x))" " cond: perhaps (cond (x)) -> x")
@@ -85770,7 +85905,7 @@ etc
" cond: cond test (< x 2) is never true: (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5))
cond: cond test repeated: ((< x 2) 5)
cond: cond test is always false: ((< x 2) 5)
- cond: perhaps (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5)) -> (cond ((< x 2) 3) ((> x 0) 4) (#f 5))")
+ cond: perhaps (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5)) -> (cond ((< x 2) 3) ((> x 0) 4))")
(lint-test "(cond ((< x 1) (+ x 1)) ((> x 1) (+ x 1)) (#t 2))"
" cond: perhaps (cond ((< x 1) (+ x 1)) ((> x 1) (+ x 1)) (#t 2)) -> (cond ((not (= x 1)) (+ x 1)) (#t 2))")
(lint-test "(cond ((= x 3) 4) ((= x 2) 4) ((= x 1) 4) (else 5))"
@@ -85784,7 +85919,9 @@ etc
" cond: no need to repeat the test: ((= x 1) (= x 1)) -> ((= x 1))
cond: perhaps use case instead of cond: (cond ((= x 0) x) ((= x 1) (= x 1))) -> (case x ((0) x) ((1) (= x 1)))")
(lint-test "(cond (x => expt))" " cond: => target (expt) may be unhappy: (x => expt)")
- (lint-test "(cond (x (abs x)))" " cond: perhaps use => here: (x (abs x)) -> (x => abs)")
+ (lint-test "(cond (x (abs x)))"
+ " in (cond (x (abs x))), perhaps change x to (real? x)
+ cond: perhaps use => here: (x (abs x)) -> (x => abs)")
(lint-test "(cond ((> x 2) (not (> x 2))))" " cond: perhaps use => here: ((> x 2) (not (> x 2))) -> ((> x 2) => not)")
(lint-test "(cond (x #t) (y #t) (else #f))" " cond: perhaps (cond (x #t) (y #t) (else #f)) -> (or x y)")
(lint-test "(cond (x #f) (y #f) (else #t))" " cond: perhaps (cond (x #f) (y #f) (else #t)) -> (not (or x y))")
@@ -85792,7 +85929,10 @@ etc
(lint-test "(cond ((x) y) ((not (x)) z))" " cond: perhaps (cond ((x) y) ((not (x)) z)) -> (cond ((x) y) (else z))")
(lint-test "(cond (x (let ((z w)) (+ x z)) y) (else 2))"
- " cond: this could be omitted: (let ((z w)) (+ x z)) cond: perhaps (let ((z w)) (+ x z)) -> (+ x w)")
+ " in (cond (x (let ((z w)) (+ x z)) y) (else 2)), perhaps change x to (number? x)
+ cond: this could be omitted: (let ((z w)) (+ x z))
+ cond: perhaps (let ((z w)) (+ x z)) -> (+ x w)
+ cond: assuming we see all set!s, (z w) is pointless: perhaps (let ((z w)) (+ x z)) -> (let () (+ x w))")
(lint-test "(cond (x (if x y z) (+ x 1)) (z 2))" " cond: this could be omitted: (if x y z)")
(lint-test "(cond ((g x) `(c ,x) `(c ,y)))"
" cond: this could be omitted: ({list} 'c x)
@@ -85882,6 +86022,18 @@ etc
(lint-test "(cond (A B) ((< C 1) (cond (D d) (else E))) (else F))"
" cond: perhaps (cond (A B) ((< C 1) (cond (D d) (else E))) (else F)) -> (cond (A B) ((>= C 1) F) (D d) (else E))")
+ (lint-test "(cond (W X) (A B) (C D) (else B))"
+ " cond: perhaps (cond (W X) (A B) (C D) (else B)) -> (cond (W X) ((or A (not C)) B) (else D))")
+ (lint-test "(cond (W X) (A #f) (C D) (else #f))"
+ " cond: perhaps (cond (W X) (A #f) (C D) (else #f)) -> (cond (W X) ((or A (not C)) #f) (else D))")
+ (lint-test "(cond (Y #t) (W X) (A #f) (C #t) (else #f))"
+ " cond: perhaps (cond (Y #t) (W X) (A #f) (C #t) (else #f)) -> (cond ... ((or A (not C)) #f) (else #t))")
+ (lint-test "(cond (W #t) (A B) (C #t) (else B))"
+ " cond: perhaps (cond (W #t) (A B) (C #t) (else B)) -> (cond (W #t) ((or A (not C)) B) (else #t))")
+ (lint-test "(cond (W B) (A B) (C #t) (else B))"
+ " cond: perhaps (cond (W B) (A B) (C #t) (else B)) -> (cond ((or W A) B) (C #t) (else B))
+ cond: perhaps (cond (W B) (A B) (C #t) (else B)) -> (cond (W B) ((or A (not C)) B) (else #t))")
+
(lint-test "(cond ((string=? x \"a\") 1) ((string=? x \"b\") 2) ((string=? x \"c\") 3) (else 4))"
" cond: perhaps (cond ((string=? x \"a\") 1) ((string=? x \"b\") 2) ((string=? x \"c\") 3) (else 4)) ->
(cond ((assq (string->symbol x) '((a . 1) (b . 2) (c . 3))) => cdr) (else 4))")
@@ -85921,7 +86073,7 @@ etc
(lint-test "(cond (A B) ((or A C) D) (C E))"
" cond: cond test C is never true: (cond (A B) ((or A C) D) (C E))
cond: cond test is always false: (C E)
- cond: perhaps (cond (A B) ((or A C) D) (C E)) -> (cond (A B) (C D) (#f E))")
+ cond: perhaps (cond (A B) ((or A C) D) (C E)) -> (cond (A B) (C D))")
(lint-test "(cond ((< x 1) 21) ((< x 2) 32) ((or (< x 1) (> x 3)) 33))"
" cond: perhaps (cond ((< x 1) 21) ((< x 2) 32) ((or (< x 1) (> x 3)) 33)) -> (cond ((assoc x '((1 . 21) (2 . 32)) <) => cdr) ((> x 3) 33))")
(lint-test "(cond ((not x) (display (+ y 1))) (else (display x)))"
@@ -85977,6 +86129,13 @@ etc
(lint-test "(cond ((< x 1) (log x 2)) ((< x 2) (log x 3)) (else (error 'oops)))"
" cond: perhaps (cond ((< x 1) (log x 2)) ((< x 2) (log x 3)) (else (error 'oops))) -> (log x (cond ((< x 1) 2) ((< x 2) 3) (else (error 'oops))))")
+ (lint-test "(cond (X (f y z)) (else (g y z)))" " cond: perhaps (cond (X (f y z)) (else (g y z))) -> ((cond (X f) (else g)) y z)")
+ (lint-test "(cond (X (f y z)) (Y (g y z)))" "")
+ (lint-test "(cond (X (f y z)) (Y (f y z)) (Z (f y z)))"
+ " cond: perhaps (cond (X (f y z)) (Y (f y z)) (Z (f y z))) -> (if (or X Y Z) (f y z))
+ cond: perhaps (cond (X (f y z)) (Y (f y z)) (Z (f y z))) -> (cond ((or X Y Z) (f y z)))")
+ (lint-test "(cond (X (g y a)) (else (g y z)))" " cond: perhaps (cond (X (g y a)) (else (g y z))) -> (g y (if X a z))")
+
(lint-test "(when (and (< x 1) y) (if z (display z)))"
" when: perhaps (when (and (< x 1) y) (if z (display z))) -> (when (and (< x 1) y z) (display z))")
(lint-test "(when y (if z (display z)))"
@@ -85999,6 +86158,12 @@ etc
" if: perhaps (if (and (< x 1) y) (when z (display z) x)) -> (when (and (< x 1) y z) (display z) x)")
(lint-test "(if (and (< x 1) y) (unless z (display z) x))"
" if: perhaps (if (and (< x 1) y) (unless z (display z) x)) -> (when (and (< x 1) y (not z)) (display z) x)")
+ (lint-test "(let ((x (g y))) (when x (display x)) (when x (set! y x)))"
+ " let: perhaps (... (when x (display x)) (when x (set! y x)) ...) -> (when x (display x) (set! y x))")
+ (lint-test "(let ((x (g y))) (unless x (display x)) (unless x (set! y x)))"
+ " let: perhaps (... (unless x (display x)) (unless x (set! y x)) ...) -> (unless x (display x) (set! y x))")
+ (lint-test "(begin (and x (display y)) (log z))" " begin: perhaps (and x (display y)) -> (if x (display y))")
+ (lint-test "(begin (or x (display y)) (log z))" " begin: perhaps (or x (display y)) -> (if (not x) (display y))")
(lint-test "(car (cons 1 2))" " car: (car (cons 1 2)) is the same as 1")
(lint-test "(car (string->list x))" " car: perhaps (car (string->list x)) -> (string-ref x 0)")
@@ -86027,6 +86192,7 @@ etc
(lint-test "(char>? x #\\a #\\b y)" " char>?: this comparison can't be true: (char>? x #\\a #\\b y)")
(lint-test "(< (char->integer x) 95)" " <: perhaps (< (char->integer x) 95) -> (char<? x #\\_)")
(lint-test "(>= (char->integer x) 90 (char->integer y))" " >=: perhaps (>= (char->integer x) 90 (char->integer y)) -> (char>=? x #\\Z y)")
+ (lint-test "(> (abs x) -1)" " >: abs can't be negative: (> (abs x) -1)")
(lint-test "(string>? \"a\" x \"b\" y)" " string>?: this comparison can't be true: (string>? \"a\" x \"b\" y)")
(lint-test "(copy (copy x))" " copy: (copy (copy x)) could be (copy x)")
@@ -86066,6 +86232,8 @@ etc
(lint-test "(reverse (list-tail (reverse slist) index))"
" reverse: perhaps (reverse (list-tail (reverse slist) index)) -> (copy slist (make-list (- (length slist) index)))")
(lint-test "(reverse (append (reverse b) res))" " reverse: perhaps (reverse (append (reverse b) res)) -> (append (reverse res) b)")
+ (lint-test "(reverse (reverse! x))" " reverse: (reverse (reverse! x)) could be (copy x)")
+ (lint-test "(reverse (string->list x))" " reverse: perhaps less consing: (reverse (string->list x)) -> (string->list (reverse x))")
; (lint-test "(let ((v (list 1 2))) (reverse! v) v)" "")
; (lint-test "(let ((v1 (list 1 2))) (set! v1 (reverse! v1)))" "")
@@ -86082,11 +86250,16 @@ etc
(lint-test "(vector->list (make-vector 3 #f))" " vector->list: perhaps (vector->list (make-vector 3 #f)) -> (make-list 3 #f)")
(lint-test "(list->vector (make-list 3 #f))" " list->vector: perhaps (list->vector (make-list 3 #f)) -> (make-vector 3 #f)")
(lint-test "(list->string (reverse x))" " list->string: perhaps (list->string (reverse x)) -> (reverse (apply string x))")
- (lint-test "(list->vector (reverse (vector->list x)))" " list->vector: perhaps (list->vector (reverse (vector->list x))) -> (reverse x)")
- (lint-test "(list->vector (reverse! (vector->list x)))" " list->vector: perhaps (list->vector (reverse! (vector->list x))) -> (reverse x)")
+ (lint-test "(list->vector (reverse (vector->list x)))"
+ " list->vector: perhaps (list->vector (reverse (vector->list x))) -> (reverse x)
+ list->vector: perhaps less consing: (reverse (vector->list x)) -> (vector->list (reverse x))")
+ (lint-test "(list->vector (reverse! (vector->list x)))"
+ " list->vector: perhaps (list->vector (reverse! (vector->list x))) -> (reverse x)
+ list->vector: perhaps less consing: (reverse! (vector->list x)) -> (vector->list (reverse x))")
(lint-test "(list->vector (copy (vector->list x)))" " list->vector: perhaps (list->vector (copy (vector->list x))) -> (copy x)")
(lint-test "(list->string (reverse (string->list (substring str 1))))"
- " list->string: perhaps (list->string (reverse (string->list (substring str 1)))) -> (reverse (substring str 1))")
+ " list->string: perhaps (list->string (reverse (string->list (substring str 1)))) -> (reverse (substring str 1))
+ list->string: perhaps less consing: (reverse (string->list (substring str 1))) -> (string->list (reverse (substring str 1)))")
(lint-test "(list->string (cdr (string->list x)))" " list->string: perhaps (list->string (cdr (string->list x))) -> (substring x 1)")
(lint-test "(list->vector (list-tail (vector->list x) y))"
" list->vector: perhaps (list->vector (list-tail (vector->list x) y)) -> (copy x (make-vector (- (length x) y))) ")
@@ -86110,25 +86283,49 @@ etc
(lint-test "(string->list x y y)" " string->list: leaving aside errors, (string->list x y y) is ()")
(lint-test "(symbol->keyword (string->symbol x))" " symbol->keyword: perhaps (symbol->keyword (string->symbol x)) -> (make-keyword x)")
+ (lint-test "(string->symbol (string-append x y z))" " string->symbol: perhaps (string->symbol (string-append x y z)) -> (symbol x y z)")
+ (lint-test "(string->symbol (apply string-append x))" " string->symbol: perhaps (string->symbol (apply string-append x)) -> (apply symbol x)")
+ (lint-test "(string->symbol (if (null? x) \"abc\" x))"
+ " string->symbol: perhaps (string->symbol (if (null? x) \"abc\" x)) -> (if (null? x) 'abc (string->symbol x))")
+ (lint-test "(string->symbol (if (not (null? x)) x \"abc\"))"
+ " string->symbol: perhaps (string->symbol (if (not (null? x)) x \"abc\")) -> (if (not (null? x)) (string->symbol x) 'abc)")
+ (lint-test "(string->symbol (if (null? x) \"abc\" \"x\"))"
+ " string->symbol: perhaps (string->symbol (if (null? x) \"abc\" \"x\")) -> (if (null? x) 'abc 'x)")
+
+ (lint-test "(equal? x (list 1 2))" " equal?: perhaps (list 1 2) -> '(1 2)")
+ (lint-test "(equal? x (list (list 1 2) (list 3 4)))" " equal?: perhaps (list (list 1 2) (list 3 4)) -> '((1 2) (3 4))")
+ (lint-test "(equal? x (vector (list 1 2) (list 3 4)))" " equal?: perhaps (vector (list 1 2) (list 3 4)) -> #((1 2) (3 4))")
+ (lint-test "(equal? x (list (vector 1 2) (list 3 (list 4 5))))" " equal?: perhaps (list (vector 1 2) (list 3 (list 4 5))) -> '(#(1 2) (3 (4 5)))")
+
(lint-test "(car (reverse x))" " car: perhaps (car (reverse x)) -> (list-ref x (- (length x) 1))")
(lint-test "(caddr (reverse! x))" " caddr: perhaps (caddr (reverse! x)) -> (list-ref x (- (length x) 3))")
(lint-test "(append 3)" " append: perhaps (append 3) -> 3")
(lint-test "(append)" " append: perhaps (append) -> ()")
(lint-test "(append (append))" " append: perhaps (append (append)) -> ()")
- (lint-test "(append '(1) (append '(2)))" " append: perhaps (append '(1) (append '(2))) -> (list 1 2)")
+ (lint-test "(append '(1) (append '(2)))"
+ " append: append does not copy its last argument, so (append '(1) (append '(2))) is dangerous
+ append: perhaps (append '(1) (append '(2))) -> (list 1 2)")
(lint-test "(append x (append))" " append: perhaps clearer: (append x (append)) -> (copy x)")
(lint-test "(append '(1 2) (list))" " append: perhaps clearer: (append '(1 2) (list)) -> (copy '(1 2))")
(lint-test "(append x '())" " append: perhaps clearer: (append x '()) -> (copy x) append: quote is not needed here: '()")
- (lint-test "(append '(1) (append 2))" " append: perhaps (append '(1) (append 2)) -> (append '(1) 2)")
- (lint-test "(append '(1) (append '(2) '(3)) '(4))" " append: perhaps (append '(1) (append '(2) '(3)) '(4)) -> (list 1 2 3 4)")
+ (lint-test "(append '(1) (append 2))" " append: perhaps (append '(1) (append 2)) -> (cons 1 2)")
+ (lint-test "(append '(1) (append '(2) '(3)) '(4))"
+ " append: append does not copy its last argument, so (append '(1) (append '(2) '(3)) '(4)) is dangerous
+ append: perhaps (append '(1) (append '(2) '(3)) '(4)) -> (list 1 2 3 4)")
(lint-test "(append (list x y) (list z))" " append: perhaps (append (list x y) (list z)) -> (list x y z)")
(lint-test "(append '(1 2) (list 3))" " append: perhaps (append '(1 2) (list 3)) -> (list 1 2 3)")
- (lint-test "(append '(1) '(2 3))" " append: perhaps (append '(1) '(2 3)) -> (list 1 2 3)")
- (lint-test "(append '(x) '((+ 1 2) #(0)))" " append: perhaps (append '(x) '((+ 1 2) #(0))) -> (list 'x '(+ 1 2) #(0))")
+ (lint-test "(append '(1) '(2 3))"
+ " append: append does not copy its last argument, so (append '(1) '(2 3)) is dangerous
+ append: perhaps (append '(1) '(2 3)) -> (list 1 2 3)")
+ (lint-test "(append '(x) '((+ 1 2) #(0)))"
+ " append: append does not copy its last argument, so (append '(x) '((+ 1 2) #(0))) is dangerous
+ append: perhaps (append '(x) '((+ 1 2) #(0))) -> (list 'x '(+ 1 2) #(0))")
;; (equal? (list 'x '(+ 1 2) #(0)) (append '(x) '((+ 1 2) #(0)))) -> #t
(lint-test "(append (list x) (list y z) (list 1))" " append: perhaps (append (list x) (list y z) (list 1)) -> (list x y z 1)")
- (lint-test "(append (list x y) '(z))" " append: perhaps (append (list x y) '(z)) -> (list x y 'z)")
+ (lint-test "(append (list x y) '(z))"
+ " append: append does not copy its last argument, so (append (list x y) '(z)) is dangerous
+ append: perhaps (append (list x y) '(z)) -> (list x y 'z)")
(lint-test "(append (list x) y)" " append: perhaps (append (list x) y) -> (cons x y)")
(lint-test "(append (list x) (list y z))" " append: perhaps (append (list x) (list y z)) -> (list x y z)")
(lint-test "(append () '(1 2) 1)" " append: perhaps (append () '(1 2) 1) -> (append '(1 2) 1)")
@@ -86136,6 +86333,12 @@ etc
" append: perhaps (append '() (append) (list 1) (list) () (list 2) ()) -> (list 1 2) append: quote is not needed here: '()")
(lint-test "(append x y (append))" " append: perhaps (append x y (append)) -> (append x y ())")
(lint-test "(append x y ())" "")
+ (lint-test "(append (list x) y (list z))" " append: perhaps (append (list x) y (list z)) -> (cons x (append y (list z)))")
+ (lint-test "(append x (list y) z)" " append: perhaps (append x (list y) z) -> (append x (cons y z))")
+ (lint-test "(append '(x) y)" " append: perhaps (append '(x) y) -> (cons 'x y)")
+ (lint-test "(append '(0) y)" " append: perhaps (append '(0) y) -> (cons 0 y)")
+ (lint-test "(begin (set! x (append x y)) (set! x (append x z w)))"
+ " begin: perhaps (set! x (append x y)) (set! x (append x z w)) -> (set! x (append x y z w))")
(lint-test "(cons x (list y z))" " cons: perhaps (cons x (list y z)) -> (list x y z)")
(lint-test "(cons x (list))" " cons: perhaps (cons x (list)) -> (list x)")
@@ -86147,6 +86350,11 @@ etc
(lint-test "(cons a (cons b (cons c '())))" " cons: perhaps (cons a (cons b (cons c '()))) -> (list a b c) cons: quote is not needed here: '()")
(lint-test "(cons (car x) (cdr x))" " cons: perhaps (cons (car x) (cdr x)) -> (copy x)")
(lint-test "(cons (cadar x) (cddar x))" " cons: perhaps (cons (cadar x) (cddar x)) -> (copy (cdar x))")
+ (lint-test "(set! x (cons a (list)))" " set!: perhaps (cons a (list)) -> (list a)")
+ (lint-test "(set! x (cons a (list b c)))" " set!: perhaps (cons a (list b c)) -> (list a b c)")
+ (lint-test "(set! x (cons a (cons b (list c d))))" " set!: perhaps (cons a (cons b (list c d))) -> (list a b c d)")
+ (lint-test "(set! x (cons a (cons b ())))" " set!: perhaps (cons a (cons b ())) -> (list a b)")
+ (lint-test "(cons 'x (or y (list 'z)))" "") ; quote for list here is incorrect
(lint-test "(sort! x abs)" " sort!: abs is a questionable sort! function")
(lint-test "(sort! x (lambda (a b) (< a b)))" " sort!: perhaps (lambda (a b) (< a b)) -> <")
@@ -86170,13 +86378,20 @@ etc
(lint-test "(letrec ((f1 (lambda (a) a))) 32)"
" letrec: letrec could be let: (letrec ((f1 (lambda (a) a))) 32)
letrec: f1 not used, initially: (lambda (a) a) from letrec")
- (lint-test "(let () (define x 3) 32)" " let: x not used, initially: 3 from define")
+ (lint-test "(letrec ((x 32) (f1 (let ((y 1)) (lambda (z) (+ x y z)))) (f2 (f1 x))) (+ x f2))"
+ " letrec: in (letrec ((x 32) (f1 (let ((y 1)) (lambda (z) (+ x y z)))) (f2 (f1 x))) (+...,
+ letrec should be letrec* because x is used in f2's value (not a function): (f1 x)")
+ (lint-test "(let () (define x 3) 32)"
+ " let: perhaps (... (define x 3) 32) -> (... (let ((x 3)) ...))
+ let: x not used, initially: 3 from define")
(lint-test "(let ((z 1)) (define x 12) (define (y a) a) 32)"
- " let: y not used, value: (define (y a) a)
+ " let: perhaps (... (define x 12) (define (y a) a) 32) -> (... (let ((x 12)) ...))
+ let: y not used, value: (define (y a) a)
let: x not used, initially: 12 from define
let: z not used, initially: 1 from let")
(lint-test "(let ((z 1)) (define x 12) (define (y a) a) (+ z 32))"
- " let: y not used, value: (define (y a) a)
+ " let: perhaps (... (define x 12) (define (y a) a) (+ z 32)) -> (... (let ((x 12)) ...))
+ let: y not used, value: (define (y a) a)
let: x not used, initially: 12 from define")
(lint-test "(let* ((a 1) (b 2) (c (+ a 1))) (* c 2))"
" let*: b not used, initially: 2 from let*
@@ -86193,11 +86408,13 @@ etc
(lint-test "(let ((a 1) (set! a 2)))" " let: let is messed up: (let ((a 1) (set! a 2)))")
(lint-test "(let ((a 1)) (set! a 2))"
" let: a set, but not used: (set! a 2)
- let: perhaps (let ((a 1)) (set! a 2)) -> 2")
+ let: perhaps (let ((a 1)) (set! a 2)) -> 2
+ let: set! is pointless in (set! a 2): use 2")
(lint-test "(let ((a 1) (b (display 2))) (set! a 2))"
" let: b not used, initially: (display 2) from let
let: a set, but not used: (set! a 2)
- let: perhaps (let ((a 1) (b (display 2))) (set! a 2)) -> (let ((b (display 2))) 2)")
+ let: perhaps (let ((a 1) (b (display 2))) (set! a 2)) -> (let ((b (display 2))) 2)
+ let: set! is pointless in (set! a 2): use 2")
(lint-test "(let ((a 1)) #f)" " let: a not used, initially: 1 from let")
(lint-test "(let :x ((i y)) (x i))" " let: bad let name: :x")
(lint-test "(let xx () z)"
@@ -86205,9 +86422,13 @@ etc
let: xx not used, value: (let xx () z)")
(lint-test "(let ((x (log y))) x)" " let: perhaps (let ((x (log y))) x) -> (log y)")
(lint-test "(let* ((x (log y))) x)" " let*: let* could be let: (let* ((x (log y))) x) let*: perhaps (let* ((x (log y))) x) -> (log y)")
- (lint-test "(let* ((y 3) (x (log y))) x)" " let*: perhaps (let* ((y 3) (x (log y))) x) -> (let ((y 3)) (log y))")
+ (lint-test "(let* ((y 3) (x (log y))) x)"
+ " let*: perhaps substitute y into x: (let* ((y 3) (x (log y))) x) -> (let ((x (log 3))) ...)
+ let*: perhaps (let* ((y 3) (x (log y))) x) -> (let ((y 3)) (log y))")
(lint-test "(let ((y 3) (x (log z))) x)" " let: y not used, initially: 3 from let")
- (lint-test "(let* ((z 3) (y z) (x (log y))) x)" " let*: perhaps (let* ((z 3) (y z) (x (log y))) x) -> (let* ((z 3) (y z)) (log y))")
+ (lint-test "(let* ((z 3) (y z) (x (log y))) x)"
+ " let*: perhaps substitute z into y: (let* ((z 3) (y z) (x (log y))) x) -> (let* ((y 3) (x (log y))) ...)
+ let*: perhaps (let* ((z 3) (y z) (x (log y))) x) -> (let* ((z 3) (y z)) (log y))")
(lint-test "(let* ((x 1) (x (+ x 1))) x)"
" let*: let* variable x is declared twice
let*: perhaps (let* ((x 1) (x (+ x 1))) x) -> (let ((x 1)) (+ x 1))")
@@ -86223,7 +86444,9 @@ etc
(lint-test "(let* ((a 1) (b (+ a 2))) (let* ((c (+ b 3)) (d (+ c 4))) (display a) (+ a b c d)))"
" let*: perhaps (let* ((a 1) (b (+ a 2))) (let* ((c (+ b 3)) (d (+ c 4))) (display a) (+ a... ->
(let* ((a 1) (b (+ a 2)) (c (+ b 3)) (d (+ c 4))) (display a) ...)")
- (lint-test "(let* ((a 1) (b (+ a 1))) b)" " let*: perhaps (let* ((a 1) (b (+ a 1))) b) -> (let ((a 1)) (+ a 1))")
+ (lint-test "(let* ((a 1) (b (+ a 1))) b)"
+ " let*: perhaps substitute a into b: (let* ((a 1) (b (+ a 1))) b) -> (let ((b (+ 1 1))) ...)
+ let*: perhaps (let* ((a 1) (b (+ a 1))) b) -> (let ((a 1)) (+ a 1))")
(lint-test "(let* ((a 1) (b (+ a 1))) (+ a b))" " let*: perhaps (let* ((a 1) (b (+ a 1))) (+ a b)) -> (let ((a 1)) (+ a (+ a 1)))")
(lint-test "(let ((x (assoc y z))) (if x (cdr x)))"
" let: perhaps (let ((x (assoc y z))) (if x (cdr x))) -> (cond ((assoc y z) => cdr))")
@@ -86268,18 +86491,22 @@ etc
(lint-test "(let ((x (f y))) (cond (x (g x)) (y z) (else y)))"
" let: perhaps (let ((x (f y))) (cond (x (g x)) (y z) (else y))) -> (cond ((f y) => g) (y z) (else y))
let: perhaps use => here: (x (g x)) -> (x => g)")
- (lint-test "(let ((x (f y))) (cond (x (set-cdr! x y)) (else y)))" "")
+ (lint-test "(let ((x (f y))) (cond (x (set-cdr! x y)) (else y)))"
+ " in (cond (x (set-cdr! x y)) (else y)), perhaps change x to (pair? x)")
(lint-test "(let () (let ((a x)) (+ a 1)))"
" let: pointless let: (let () (let ((a x)) (+ a 1))) -> (let ((a x)) (+ a 1))
let: perhaps (let () (let ((a x)) (+ a 1))) -> (let ((a x)) (+ a 1))
- let: perhaps (let ((a x)) (+ a 1)) -> (+ x 1)")
+ let: perhaps (let ((a x)) (+ a 1)) -> (+ x 1)
+ let: assuming we see all set!s, (a x) is pointless: perhaps (let ((a x)) (+ a 1)) -> (let () (+ x 1))")
(lint-test "(let ((a x)) (let () (+ a 1)))"
" let: pointless let: (let ((a x)) (let () (+ a 1))) -> (let ((a x)) (+ a 1))
let: perhaps (let ((a x)) (let () (+ a 1))) -> (let () (+ x 1))
let: pointless let: (let () (+ a 1))
- let: perhaps (let () (+ a 1)) -> (+ a 1)")
+ let: perhaps (let () (+ a 1)) -> (+ a 1)
+ let: assuming we see all set!s, (a x) is pointless: perhaps (let ((a x)) (let () (+ a 1))) -> (let () (let () (+ x 1)))")
(lint-test "(let ((x 32)) (define x 33) x)"
- " let: define returns the new value, so this could be omitted: x
+ " let: perhaps (... (define x 33) x) -> (... (let ((x 33)) ...))
+ let: perhaps omit x and return 33
let: let variable x is redefined in the let body. Perhaps use set! instead: (set! x 33)
let: x not used, initially: 32 from let")
(lint-test "(let ((x 32)) (define (x y) (+ y 33)) (x 1))"
@@ -86297,7 +86524,8 @@ etc
(lint-test "(let ((x (f 0)) (y (f 1))) (or x y))"
" let: perhaps, ignoring short-circuit issues, (let ((x (f 0)) (y (f 1))) (or x y)) -> (or (f 0) (f 1))")
(lint-test "(let ((x (undo-edit))) (set! y (or y x)))"
- " let: perhaps, ignoring short-circuit issues, (let ((x (undo-edit))) (set! y (or y x))) -> (set! y (or y (undo-edit)))")
+ " let: perhaps, ignoring short-circuit issues, (let ((x (undo-edit))) (set! y (or y x))) -> (set! y (or y (undo-edit)))
+ let: perhaps (set! y (or y x)) -> (if (not y) (set! y x))")
(lint-test "(let ((x 1)) (set! x 2) (+ x 1))"
" let: perhaps (let ((x 1)) (set! x 2) (+ x 1)) -> (let ((x 2)) (+ x 1))")
@@ -86309,16 +86537,18 @@ etc
(lint-test "(let ((x (f y))) (if x (g x) (set! x 3)))" "") ; too complicated to deal with this
(lint-test "(let* ((x (f y))) (if x (g x) (set! x 3)))" " let*: let* could be let: (let* ((x (f y))) (if x (g x) (set! x 3)))")
(lint-test "(let* ((z 1) (x (< z 2))) (if x (f x)))"
- " let*: perhaps (let* ((z 1) (x (< z 2))) (if x (f x))) -> (let ((z 1)) (cond ((< z 2) => f)))")
+ " let*: perhaps substitute z into x: (let* ((z 1) (x (< z 2))) (if x (f x))) -> (let ((x (< 1 2))) ...)
+ let*: perhaps (let* ((z 1) (x (< z 2))) (if x (f x))) -> (let ((z 1)) (cond ((< z 2) => f)))")
(lint-test "(let* ((z 1) (y (+ z 2)) (x (< y 3))) (if x (f x)))"
- " let*: perhaps (let* ((z 1) (y (+ z 2)) (x (< y 3))) (if x (f x))) -> (let* ((z 1) (y (+ z 2))) (cond ((< y 3) => f)))")
+ " let*: perhaps substitute z into y: (let* ((z 1) (y (+ z 2)) (x (< y 3))) (if x (f x))) -> (let* ((y (+ 1 2)) (x (< y 3))) ...)
+ let*: perhaps (let* ((z 1) (y (+ z 2)) (x (< y 3))) (if x (f x))) -> (let* ((z 1) (y (+ z 2))) (cond ((< y 3) => f)))")
(lint-test "(let f0 ((i 1)) (if (> i 0) (f0 #() (- i 1))))" " f0: f0 has too many arguments: (f0 #() (- i 1))")
(lint-test "(letrec ((f0 (lambda (i) (if (> i 0) (f0 #() (- i 1)))))) (f0 1))"
" letrec: perhaps (letrec ((f0 (lambda (i) (if (> i 0) (f0 #() (- i 1)))))) (f0 1)) -> (let f0 ((i 1)) (if (> i 0) (f0 #() (- i 1))))")
(lint-test "(letrec ((f0 (lambda () (if (> i 0) (f0))))) (f0))"
" letrec: perhaps (letrec ((f0 (lambda () (if (> i 0) (f0))))) (f0)) -> (let f0 () (if (> i 0) (f0)))")
- (lint-test "(let () (error 'oops \"an error\") #t)" " let: (error 'oops \"an error\") make this pointless: #t")
+ (lint-test "(let () (error 'oops \"an error\") #t)" " let: (error 'oops \"an error\") makes this pointless: #t")
(lint-test "(let () (error 'oops \"an error\") (display \"oops\") #t)"
" let: (error 'oops \"an error\") makes the rest of the body unreachable: (... (display \"oops\") ...)")
(lint-test "(let ((a 1)) (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d)))))"
@@ -86333,10 +86563,12 @@ etc
" let: perhaps (let ((a 1) (b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((a 1) (b 2) (c 3) (d 4)) (display a) ...)")
(lint-test "(let ((x 1) (y x)) (+ x y))"
" let: x in (y x) does not appear to be defined in the calling environment
- let: perhaps (let ((x 1) (y x)) (+ x y)) -> (+ 1 x)")
+ let: perhaps (let ((x 1) (y x)) (+ x y)) -> (+ 1 x)
+ let: assuming we see all set!s, (y x) is pointless: perhaps (let ((x 1) (y x)) (+ x y)) -> (let ((x 1)) (+ x x))")
(lint-test "(let ((x 3)) (+ x (let ((x 1) (y x)) (+ x y))))"
" let: x in (y x) refers to the caller's x, not the let variable
- let: perhaps (let ((x 1) (y x)) (+ x y)) -> (+ 1 x)")
+ let: perhaps (let ((x 1) (y x)) (+ x y)) -> (+ 1 x)
+ let: assuming we see all set!s, (y x) is pointless: perhaps (let ((x 1) (y x)) (+ x y)) -> (let ((x 1)) (+ x x))")
(lint-test "(let ((x 0)) (define* (f52 (a 2)) (if (zero? a) x (f52 (- a 1)))) (display x) (if (zero? x) (+ 1 (f52 x))))"
" let: perhaps (... (define* (f52 (a 2)) (if (zero? a) x (f52 (- a 1)))) (display x) (if... ->
(... (display x) (if (zero? x) (+ 1 (let* f52 ((a x)) (if (zero? a) x (f52 (- a 1)))))))
@@ -86428,9 +86660,8 @@ etc
(lint-test "(equal? x ())" " equal?: equal? could be null?: (equal? x ()) -> (null? x)")
(lint-test "(equal? x '())" " equal?: equal? could be null?: (equal? x '()) -> (null? x) equal?: quote is not needed here: '()")
(lint-test "(equal? (expt x y) z)" " equal?: equal? could be eqv? in (equal? (expt x y) z)")
- (lint-test "(morally-equal? x 'a)" " morally-equal?: morally-equal? could be eq? in (morally-equal? x 'a)")
(lint-test "(morally-equal? x 0)" "")
- (lint-test "(morally-equal? x 0.0)" "")
+ (lint-test "(morally-equal? (abs x) 0.0)" "")
(lint-test "(equal? (floor x) (round y))" " equal?: equal? could be eqv? or = in (equal? (floor x) (round y))")
(lint-test "(equal? (string x) (string-append y z))" " equal?: equal? could be string=? in (equal? (string x) (string-append y z))")
(lint-test "(eqv? (integer->char x) #\\null)" " eqv?: eqv? could be char=? in (eqv? (integer->char x) #\\null)")
@@ -86439,7 +86670,9 @@ etc
(lint-test "(eqv? #\\Space x)" " reader[0]: unknown # object: #\\Space perhaps use #\\space instead")
(lint-test "(equal? (length x) (length y))" " equal?: equal? could be eqv? in (equal? (length x) (length y))")
(lint-test "(equal? (string->number x) (string->number y))" " equal?: equal? could be eqv? in (equal? (string->number x) (string->number y))")
-
+ (lint-test "(eqv? \":\" (string-ref s 0))"
+ " eqv?: this can't be right: (eqv? \":\" (string-ref s 0))
+ eqv?: eqv? should be equal? in (eqv? \":\" (string-ref s 0))")
(lint-test "(char-ci=? x #\\return)" " char-ci=?: char-ci=? could be char=? here: (char-ci=? x #\\return)")
(lint-test "(map abs '(1 2) '(3 4))" " map: map has too many arguments in: (map abs '(1 2) '(3 4))")
@@ -86472,6 +86705,8 @@ etc
(lint-test "(for-each display (list a))"
" for-each: perhaps (for-each display (list a)) -> (display a)
for-each: perhaps (for-each display (list a)) -> (format () \"~A\" a)")
+ (lint-test "(map display (vector 'a 'b 'c))" " map: perhaps (vector 'a 'b 'c) -> #(a b c)")
+ (lint-test "(map (lambda (v) #f) y)" " map: perhaps (map (lambda (v) #f) y) -> (make-list (abs (length y)) #f)")
(lint-test "(catch #(0) (lambda () #f) (lambda a a))" " catch: catch tag #(0) is unreliable (catch uses eq? to match tags)")
(lint-test "(catch 'hi x y)" "")
@@ -86497,13 +86732,27 @@ etc
(lint-test "(+ . 1)" " +: unexpected dot: (+ . 1)")
(lint-test "(length (a . b))" " length: missing quote? (a . b) in (length (a . b))")
(lint-test "(length ,a)" " length: stray comma? (unquote a) in (length (unquote a))")
+ (lint-test "(make-vector (length (append x y)))" " make-vector: perhaps (length (append x y)) -> (+ (length x) (length y))")
+ (lint-test "(make-float-vector 3 0.0)" " make-float-vector: 0.0 is the default initial value in (make-float-vector 3 0.0)")
+ (lint-test "(make-vector 3 #<unspecified>)" " make-vector: #<unspecified> is the default initial value in (make-vector 3 #<unspecified>)")
+ (lint-test "(make-vector 3 #\\null #t)"
+ " make-vector: make-vector has too many arguments: (make-vector 3 #\\null #t)
+ make-vector: make-vector no longer has a fourth argument: (make-vector 3 #\\null #t)")
(lint-test "(set! a b c)" " set!: set! has too many arguments: (set! a b c)")
(lint-test "(set! a)" " set!: set! has too few arguments: (set! a)")
- (lint-test "(set! (vector-ref v 0) 3)" " set!: vector-ref as target of set! (set! (vector-ref v 0) 3)")
- (lint-test "(set! pi 3)" " set!: can't set! (set! pi 3) (it is a constant)")
- (lint-test "(set! 3 1)" " set!: can't set! (set! 3 1)")
- (lint-test "(set! a a)" " set!: pointless set! (set! a a)")
+ (lint-test "(set! (vector-ref v 0) 3)" " set!: vector-ref as target of set! (set! (vector-ref v 0) 3)")
+ (lint-test "(set! pi 3)" " set!: can't set! (set! pi 3) (it is a constant)")
+ (lint-test "(set! 3 1)" " set!: can't set! (set! 3 1)")
+ (lint-test "(set! a a)" " set!: pointless set! (set! a a)")
+ (lint-test "(set! x (if y x 1))" " set!: perhaps (set! x (if y x 1)) -> (if (not y) (set! x 1))")
+ (lint-test "(set! x (if y 1 x))" " set!: perhaps (set! x (if y 1 x)) -> (if y (set! x 1))")
+ (lint-test "(set! x (and x y))" " set!: perhaps (set! x (and x y)) -> (if x (set! x y))")
+ (lint-test "(set! x (and y x))" " set!: perhaps (set! x (and y x)) -> (if (not y) (set! x #f))")
+ (lint-test "(set! x (or x y))" " set!: perhaps (set! x (or x y)) -> (if (not x) (set! x y))")
+ (lint-test "(set! x (or y x))" "")
+
+
(lint-test "(begin (set! x (cons 1 z)) (set! x (cons 2 x)))" " begin: perhaps (set! x (cons 1 z)) (set! x (cons 2 x)) -> (set! x (cons 2 (cons 1 z)))")
(lint-test "(begin (set! x 0) (set! x 1))" " begin: this could be omitted: (set! x 0)")
(lint-test "(begin (set! x y) (set! x (+ x 1)))" " begin: perhaps (set! x y) (set! x (+ x 1)) -> (set! x (+ y 1))")
@@ -86621,6 +86870,13 @@ etc
(lint-test "(case x ((:symbol) (display x) (+ x 1)))" " case: perhaps (case x ((:symbol) (display x) (+ x 1))) -> (when (eq? x :symbol) (display x) (+ x 1))")
(lint-test "(case x ((0) (log x 2)) ((1) (log x 3)) (else (error 'oops)))"
" case: perhaps (case x ((0) (log x 2)) ((1) (log x 3)) (else (error 'oops))) -> (log x (case x ((0) 2) ((1) 3) (else (error 'oops))))")
+ (lint-test "(case x ((a) (f y z)) (else (g y z)))" " case: perhaps (case x ((a) (f y z)) (else (g y z))) -> ((if (eq? x 'a) f g) y z)")
+ (lint-test "(case x ((a b) (f y z)) (else (g y z)))" " case: perhaps (case x ((a b) (f y z)) (else (g y z))) -> ((case x ((a b) f) (else g)) y z)")
+ (lint-test "(case x ((a) (f y a)) (else (f y z)))" " case: perhaps (case x ((a) (f y a)) (else (f y z))) -> (f y (if (eqv? x a) a z))")
+
+ (lint-test "(if (not sym) (set! sym (eqv-selector p)) (equal? sym (eqv-selector p)))" "")
+ (lint-test "(cond (X (f y z)) (else (set! y z)))" "")
+ (lint-test "(case x ((a) (set! y z)) (else (g y z)))" " case: perhaps (case x ((a) (set! y z)) (else (g y z))) -> (if (eq? x 'a) (set! y z) (g y z))")
(lint-test "(do ())" " do: do is messed up: (do ())")
(lint-test "(do () ())" " do: this do-loop could be replaced by (): (do () ())")
@@ -86658,12 +86914,11 @@ etc
(lint-test "(begin (do ((i 0 (+ i 1))) ((= i 10) i) (display i)) x)"
" begin: (do ((i 0 (+ i 1))) ((= i 10) i) (display i)): result i is not used")
(lint-test "(do ((p (list 1) (cdr p))) ((null? p)) (display p))" "")
- (let ((old-do *report-constant-expressions-in-do*))
- (set! *report-constant-expressions-in-do* #t)
+ (let-temporarily ((*report-constant-expressions-in-do* #t))
(lint-test "(do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (display x))"
- " do: in (do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (display x)), (log z 2) appears to be constant")
- (set! *report-constant-expressions-in-do* old-do))
+ " do: in (do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (display x)), (log z 2) appears to be constant"))
(lint-test "(do ((p (list 1) (cdr p))) ((null? p)) (set! y (log z 2)) (do ((z z (+ z 1))) ((= z 0)) (display z)) (display x))" "")
+ (lint-test "(do ((i 0 (+ i 1))) ((= i 3) ()) (display i))" " do: nil return value is redundant: ((= i 3) ())")
(lint-test "(let ((xx 0)) (do ((x 1 (+ x 1)) (y x (- y 1))) ((= x 3) xx) (display y)))"
" let: x in (y x (- y 1)) does not appear to be defined in the calling environment
@@ -86735,11 +86990,17 @@ etc
" let*: perhaps (let ((c (+ a b))) (display c)) -> (display (+ a b))
let*: perhaps (let* ((a 1) (b (+ a 1))) (let ((c (+ a b))) (display c))) -> (let* ((a 1) (b (+ a 1)) (c (+ a b))) (display c))")
(lint-test "(let* ((a 1) (b (+ a 1))) (let* ((c (+ a b)) (d (+ c 1))) (display d)) (display a))"
- " let*: perhaps (let* ((c (+ a b)) (d (+ c 1))) (display d)) -> (let ((c (+ a b))) (display (+ c 1)))")
+ " let*: perhaps substitute c into d: (let* ((c (+ a b)) (d (+ c 1))) (display d)) -> (let ((d (+ (+ a b) 1))) ...)
+ let*: perhaps (let* ((c (+ a b)) (d (+ c 1))) (display d)) -> (let ((c (+ a b))) (display (+ c 1)))")
(lint-test "(let* ((a 1) (b (+ a 1))) (let ((c (+ a b)) (d a)) (display (+ c d))))"
- " let*: perhaps (let ((c (+ a b)) (d a)) (display (+ c d))) -> (display (+ (+ a b) a))")
+ " let*: perhaps (let ((c (+ a b)) (d a)) (display (+ c d))) -> (display (+ (+ a b) a))
+ let*: assuming we see all set!s, (d a) is pointless: perhaps (let ((c (+ a b)) (d a)) (display (+ c d))) -> (let ((c (+ a b))) (display (+ c a)))")
(lint-test "(let* ((x (log y 2)) (y (log y 2)) (z (f x))) (+ x y z z))" " let*: y's value (log y 2) could be x")
(lint-test "(let* ((x (log a 2)) (y (log y 2)) (z (log y 2))) (+ x y z z))" "")
+ (lint-test "(let* ((a 12) (b (+ a 1)) (c 20) (d (+ c 1))) (+ b d))"
+ " let*: perhaps substitute a into b, c into d:
+ (let* ((a 12) (b (+ a 1)) (c 20) (d (+ c 1))) (+ b d)) -> (let* ((b (+ 12 1)) (d (+ 20 1))) ...)
+ let*: perhaps (let* ((a 12) (b (+ a 1)) (c 20) (d (+ c 1))) (+ b d)) -> (let* ((a 12) (b (+ a 1)) (c 20)) (+ b (+ c 1)))")
(lint-test "(let ((a 1)) (let ((b (+ a 1))) (+ a b)))"
" let: perhaps (let ((b (+ a 1))) (+ a b)) -> (+ a (+ a 1))
let: perhaps (let ((a 1)) (let ((b (+ a 1))) (+ a b))) -> (let* ((a 1) (b (+ a 1))) (+ a b))")
@@ -86758,7 +87019,8 @@ etc
let: perhaps (let ((x (read-byte)) (y 2)) (set! x (* y x)) x) -> (let ((x (read-byte)) (y 2)) (* y x))")
(lint-test "(let ((x (read-byte)) (y 2)) (set! x (* y 2)))"
" let: x set, but not used: (set! x (* y 2))
- let: perhaps (let ((x (read-byte)) (y 2)) (set! x (* y 2))) -> (let ((x (read-byte)) (y 2)) (* y 2))")
+ let: perhaps (let ((x (read-byte)) (y 2)) (set! x (* y 2))) -> (let ((x (read-byte)) (y 2)) (* y 2))
+ let: set! is pointless in (set! x (* y 2)): use (* y 2)")
(lint-test "(let ((x 1) (y 2)) (set! x (* y x)) x)"
" let: set! returns the new value, so this could be omitted: x
let: perhaps (let ((x 1) (y 2)) (set! x (* y x)) x) -> (let ((x 1) (y 2)) (* y x))")
@@ -86773,8 +87035,42 @@ etc
(lint-test "(let loop ((i 0)) (+ i 1))" " let: loop not used, value: (let loop ((i 0)) (+ i 1))")
(lint-test "(let () (define x 3) (define (y a) a) (g z))"
- " let: y not used, value: (define (y a) a)
+ " let: perhaps (... (define x 3) (define (y a) a) (g z)) -> (... (let ((x 3)) ...))
+ let: y not used, value: (define (y a) a)
let: x not used, initially: 3 from define")
+ (lint-test "(let* ((x y) (a (* 2 x))) (+ (f a (+ a 1)) (* 3 x)))"
+ " let*: assuming we see all set!s, (x y) is pointless: perhaps (let* ((x y) (a (* 2 x))) (+ (f a (+ a 1)) (* 3 x))) ->
+ (let ((a (* 2 y))) (+ (f a (+ a 1)) (* 3 y)))")
+ (lint-test "(let* ((x y) (a (* 2 (+ x y)))) (+ (f a (+ a 1)) (* 3 x)))"
+ " let*: assuming we see all set!s, (x y) is pointless: perhaps (let* ((x y) (a (* 2 (+ x y)))) (+ (f a (+ a 1)) (* 3 x))) ->
+ (let ((a (* 2 (+ y y)))) (+ (f a (+ a 1)) (* 3 y)))")
+ (lint-test "(let* ((x y) (a (* 2 x))) (set! x (* 3 x)) (+ (f a (+ a 1)) (* 3 x)))" "")
+ (lint-test "(let* ((x y) (a (* 2 x))) (set! y (* 3 x)) (+ (f a (+ a 1)) (* 3 x)))" "")
+ (lint-test "(let* ((x y) (a (* 2 x))) (cons (push! a x) (* 3 x)))" "")
+ (lint-test "(let* ((x y) (a (* 2 x))) (cons (push! a y) (* 3 x)))" "")
+ (lint-test "(let ((x y) (a (* 2 y))) (+ (f a (+ a 1)) (* 3 x)))"
+ " let: assuming we see all set!s, (x y) is pointless: perhaps (let ((x y) (a (* 2 y))) (+ (f a (+ a 1)) (* 3 x))) ->
+ (let ((a (* 2 y))) (+ (f a (+ a 1)) (* 3 y)))")
+ (lint-test "(let ((x y) (a (* 2 y))) (+ (f a (+ a 1)) (* 3 y x)))"
+ " let: assuming we see all set!s, (x y) is pointless: perhaps (let ((x y) (a (* 2 y))) (+ (f a (+ a 1)) (* 3 y x))) ->
+ (let ((a (* 2 y))) (+ (f a (+ a 1)) (* 3 y y)))")
+ (lint-test "(let ((x y) (a (* 2 y))) (set! x (* 3 x)) (+ (f a (+ a 1)) (* 3 x)))" "")
+ (lint-test "(let ((x y) (a (* 2 y))) (set! y (* 3 x)) (+ (f a (+ a 1)) (* 3 x)))" "")
+
+ (lint-test "(let ((old-x x)) (set! x 12) (display (log x)) (set! x old-x))"
+ " let: perhaps use let-temporarily here (see stuff.scm):
+ (let ((old-x x)) (set! x 12) (display (log x)) (set! x old-x)) -> (let-temporarily ((x 12)) (display (log x)))")
+ (lint-test "(let ((old-x x)) (set! x 12) (display (log x)) (set! x 1) (set! x old-x))"
+ " let: this could be omitted: (set! x 1)
+ let: perhaps use let-temporarily here (see stuff.scm):
+ (let ((old-x x)) (set! x 12) (display (log x)) (set! x 1) (set! x old-x)) -> (let-temporarily ((x 12)) (display (log x)) (set! x 1))")
+ (lint-test "(let ((old-x x) (z (f 3))) (set! x z) (display (log x)) (set! x old-x))"
+ " let: perhaps use let-temporarily here (see stuff.scm):
+ (let ((old-x x) (z (f 3))) (set! x z) (display (log x)) (set! x old-x)) -> (let ((z (f 3))) (let-temporarily ((x z)) (display (log x))))")
+ (lint-test "(let ((z (f 3)) (old-x x)) (set! x z) (display (log x)) (set! x old-x))"
+ " let: perhaps use let-temporarily here (see stuff.scm):
+ (let ((z (f 3)) (old-x x)) (set! x z) (display (log x)) (set! x old-x)) -> (let ((z (f 3))) (let-temporarily ((x z)) (display (log x))))")
+
(lint-test "(letrec () 1)" " letrec: letrec could be let: (letrec () 1)")
(lint-test "(letrec* ((a (lambda b (a 1)))) a)" " letrec*: letrec* could be letrec: (letrec* ((a (lambda b (a 1)))) a)")
(lint-test "(letrec* ((x 12) (x y)) x)"
@@ -86784,6 +87080,8 @@ etc
(lint-test "(letrec ((x x)) x)" " letrec: (x x) is the same as (x #<undefined>) in letrec")
(lint-test "(letrec* ((x x)) x)"
" letrec*: letrec* could be letrec: (letrec* ((x x)) x) letrec*: (x x) is the same as (x #<undefined>) in letrec*")
+ (lint-test "(letrec* ((x 1) (y (log 2))) (+ (g x) y))" " letrec*: letrec* could be let: (letrec* ((x 1) (y (log 2))) (+ (g x) y))")
+
(lint-test "(begin . 1)" " begin: stray dot in begin? (begin . 1)")
(lint-test "(begin (map abs x) #f)" " begin: this could be omitted: (map abs x)")
(lint-test "(begin (map display x) #f)" " begin: map could be for-each: (for-each display x)")
@@ -86826,6 +87124,7 @@ etc
" format: format arg (make-string len c) could use the format directive ~NC and change the argument to ... len c ...")
(lint-test "(format #f \"~A\" (make-string len #\\space))"
" format: format arg (make-string len #\\space) could use the format directive ~NC and change the argument to ... len #\\space ...")
+ (lint-test "(f \"*****************************\")" " f: perhaps \"*****************************\" -> (format #f \"~NC\" 29 #\\*)")
(lint-test "(for-each (lambda (x) (display x)) args)"
" for-each: perhaps (for-each (lambda (x) (display x)) args) -> (format () \"~{~A~}\" args) for-each: perhaps (lambda (x) (display x)) -> display")
@@ -86863,23 +87162,38 @@ etc
" receive: perhaps (call-with-values (lambda () (current-input-status elt)) (lambda (value... ->
((lambda (value submitter) #f) (current-input-status elt))")
- (lint-test "(multiple-value-bind (a b) (f) b)" "")
- (lint-test "(multiple-value-bind (a b) (values 2 3) b)" "")
+ (lint-test "(multiple-value-bind (a b) (f) b)"
+ " multiple-value-bind: perhaps (multiple-value-bind (a b) (f) b) -> ((lambda (a b) b) (f))")
+ (lint-test "(multiple-value-bind (a b) (values 2 3) b)"
+ " multiple-value-bind: perhaps (multiple-value-bind (a b) (values 2 3) b) -> ((lambda (a b) b) (values 2 3))")
(lint-test "(multiple-value-bind (a b c d) (values 2 (values 3 4) 5) (+ a b c d))"
- " multiple-value-bind: perhaps (values 2 (values 3 4) 5) -> (values 2 3 4 5)")
- (lint-test "(multiple-value-bind (a b) (values 1 2 3) b)" " multiple-value-bind: multiple-value-bind wants 2 values, but (values 1 2 3) returns 3")
- (lint-test "(multiple-value-bind (a b) (f) (cons a b))" " multiple-value-bind: perhaps (multiple-value-bind (a b) (f) (cons a b)) -> (cons (f))")
+ " multiple-value-bind: perhaps (multiple-value-bind (a b c d) (values 2 (values 3 4) 5) (+ a b c d)) ->
+ ((lambda (a b c d) (+ a b c d)) (values 2 (values 3 4) 5))
+ multiple-value-bind: perhaps (values 2 (values 3 4) 5) -> (values 2 3 4 5)")
+ (lint-test "(multiple-value-bind (a b) (values 1 2 3) b)"
+ " multiple-value-bind: multiple-value-bind wants 2 values, but (values 1 2 3) returns 3
+ multiple-value-bind: perhaps (multiple-value-bind (a b) (values 1 2 3) b) -> ((lambda (a b) b) (values 1 2 3))")
+ (lint-test "(multiple-value-bind (a b) (f) (cons a b))"
+ " multiple-value-bind: perhaps (multiple-value-bind (a b) (f) (cons a b)) -> (cons (f))")
(lint-test "(multiple-value-bind (a b) (values 1 2) (cons a b))"
" multiple-value-bind: perhaps (multiple-value-bind (a b) (values 1 2) (cons a b)) -> (cons (values 1 2))")
+ (lint-test "(multiple-value-bind (a b) (f) b)" " multiple-value-bind: perhaps (multiple-value-bind (a b) (f) b) -> ((lambda (a b) b) (f))")
+
(lint-test "(let () (define (f1) (values 2 3 4)) (multiple-value-bind (a b) (f1) (+ a b)))"
- " let: perhaps (... (define (f1) (values 2 3 4)) (multiple-value-bind (a b) (f1) (+ a b))) -> (... (multiple-value-bind (a b) (values 2 3 4) (+ a b)))
- let: multiple-value-bind wants 2 values, but (f1) returns 3")
+ " let: perhaps (... (define (f1) (values 2 3 4)) (multiple-value-bind (a b) (f1) (+ a b))) ->
+ (... (multiple-value-bind (a b) (values 2 3 4) (+ a b)))
+ let: multiple-value-bind wants 2 values, but (f1) returns 3
+ let: perhaps (multiple-value-bind (a b) (f1) (+ a b)) -> ((lambda (a b) (+ a b)) (f1))")
(lint-test "(let () (define (f1) (values 2)) (multiple-value-bind (a b) (f1) (+ a b)))"
- " let: perhaps (... (define (f1) (values 2)) (multiple-value-bind (a b) (f1) (+ a b))) -> (... (multiple-value-bind (a b) (values 2) (+ a b)))
+ " let: perhaps (... (define (f1) (values 2)) (multiple-value-bind (a b) (f1) (+ a b))) ->
+ (... (multiple-value-bind (a b) (values 2) (+ a b)))
f1: perhaps (values 2) -> 2
- let: multiple-value-bind wants 2 values, but (f1) returns 1")
+ let: multiple-value-bind wants 2 values, but (f1) returns 1
+ let: perhaps (multiple-value-bind (a b) (f1) (+ a b)) -> ((lambda (a b) (+ a b)) (f1))")
(lint-test "(let () (multiple-value-bind (a b) ((lambda () (values 1 2 3))) (+ a b)))"
" let: multiple-value-bind wants 2 values, but ((lambda () (values 1 2 3))) returns 3
+ let: perhaps (multiple-value-bind (a b) ((lambda () (values 1 2 3))) (+ a b)) ->
+ ((lambda (a b) (+ a b)) ((lambda () (values 1 2 3))))
let: perhaps ((lambda () (values 1 2 3))) -> (values 1 2 3)")
(lint-test "(let*-values (((a b) (f x))) (+ a b))"
@@ -86958,6 +87272,8 @@ etc
(... (write-string x p y z) (write-string \"1234\" p 1) (write-string \"5678\"... ->
(format p \"~A2347~A\" (substring x y z) (substring \"abc\" 2 z))")
(lint-test "(display x #f)" "") ; #f is ok here = no output
+ (lint-test "(read-line in-port 'concat)"
+ " read-line: the third argument should be boolean (#f=default, #t=include trailing newline): (read-line in-port 'concat)")
(lint-test "(+ 1 (begin (x y) #\\a))" " +: in (+ 1 (begin (x y) #\\a)), +'s argument 2 should be a number, but #\\a is a char?")
(lint-test "(+ 1 (cond ((x 1) 3) ((x 2) 1+i) ((x 3) '(1 2))))"
@@ -86967,6 +87283,15 @@ etc
(lint-test "(substring x 0)" " substring: perhaps clearer: (substring x 0) -> (copy x)")
(lint-test "(substring (substring x 1) 2)" " substring: perhaps (substring (substring x 1) 2) -> (substring x 3)")
(lint-test "(substring x (+ y 1) (+ y 1))" " substring: leaving aside errors, (substring x (+ y 1) (+ y 1)) is \"\"")
+ (lint-test "(substring x 0 (length x))" " substring: perhaps (substring x 0 (length x)) -> (substring x 0)")
+ (lint-test "(let ((len (string-length x))) (substring x 1 len))"
+ " let: perhaps (let ((len (string-length x))) (substring x 1 len)) -> (substring x 1 (string-length x))
+ let: perhaps, if len is still (string-length x), (substring x 1 len) -> (substring x 1)")
+ (lint-test "(substring (string-append str (make-string len #\\space)) 0 len)"
+ " substring: perhaps (substring (string-append str (make-string len #\\space)) 0 len) -> (copy str (make-string len #\\space))")
+ (lint-test "(substring \"--------\" x)" " substring: perhaps (substring \"--------\" x) -> (make-string (- 8 x) #\\-)")
+ (lint-test "(substring \"--------\" x y)" " substring: perhaps (substring \"--------\" x y) -> (make-string (- y x) #\\-)")
+
(lint-test "(list-tail x 0)" " list-tail: perhaps (list-tail x 0) -> x")
(lint-test "(list-tail (list-tail x 1) 2)" " list-tail: perhaps (list-tail (list-tail x 1) 2) -> (list-tail x 3)")
(lint-test "(list-tail (list-tail x y) z)" " list-tail: perhaps (list-tail (list-tail x y) z) -> (list-tail x (+ y z))")
@@ -87046,10 +87371,21 @@ etc
(lint-test "(or (<= x 1) (<= 2 x))" " or: perhaps (or (<= x 1) (<= 2 x)) -> (not (< 1 x 2))")
(lint-test "(or (char<? x #\\1) (char>=? x #\\1))" " or: perhaps (or (char<? x #\\1) (char>=? x #\\1)) -> #t")
(lint-test "(or (string<? x \"1\") (string<? x \"2\"))" " or: perhaps (or (string<? x \"1\") (string<? x \"2\")) -> (string<? x \"2\")")
- (lint-test "(or (integer? x) (< x 3) (> x 12))" " or: perhaps (or (integer? x) (< x 3) (> x 12)) -> (or (integer? x) (not (>= 12 x 3)))")
+ (lint-test "(or (integer? x) (< x 3) (> x 12))" " or: perhaps (or (integer? x) (< x 3) (> x 12)) -> (or (integer? x) (not (<= 3 x 12)))")
(lint-test "(or (zero? x) (positive? x))" " or: perhaps (or (zero? x) (positive? x)) -> (not (negative? x))")
(lint-test "(or (zero? x) (negative? x))" " or: perhaps (or (zero? x) (negative? x)) -> (not (positive? x))")
+ (lint-test "(and (<= x y) (<= y z) (f x y z))" " and: perhaps (and (<= x y) (<= y z) (f x y z)) -> (and (<= x y z) (f x y z))")
+ (lint-test "(and (<= x y) (<= y z))" " and: perhaps (and (<= x y) (<= y z)) -> (<= x y z)")
+ (lint-test "(or (< x y) (> x z))" " or: perhaps (or (< x y) (> x z)) -> (not (<= y x z))")
+ (lint-test "(or (>= x y) (<= x z))" " or: perhaps (or (>= x y) (<= x z)) -> (not (> y x z))")
+ (lint-test "(or (< (car v1) (car v2)) (> (car v1) (car v2)))"
+ " or: perhaps (or (< (car v1) (car v2)) (> (car v1) (car v2))) -> (not (= (car v1) (car v2)))")
+ (lint-test "(or (< (car v1) (car v2)) (>= (car v1) (car v2)))"
+ " or: perhaps (or (< (car v1) (car v2)) (>= (car v1) (car v2))) -> #t")
+ (lint-test "(or (<= (car v1) (car v2)) (>= (car v1) (car v2)))"
+ " or: perhaps (or (<= (car v1) (car v2)) (>= (car v1) (car v2))) -> #t")
+
(lint-test "(or (and A B) (and (not A) (not B)))" " or: perhaps (or (and A B) (and (not A) (not B))) -> (eq? (not A) (not B))")
(lint-test "(or (and A (not B)) (and (not A) B))" " or: perhaps (or (and A (not B)) (and (not A) B)) -> (not (eq? (not A) (not B)))")
(lint-test "(or (and A B) (and (not A) C))" " or: perhaps (or (and A B) (and (not A) C)) -> (if A B C)")
@@ -87081,7 +87417,14 @@ etc
" or: perhaps (or (> y 32) (> z 32) (eq? x 'a) (eq? x 'b) (eq? x 'c) (< z 3) (> z 4)) ->
(or (> y 32) (> z 32) (memq x '(a b c)) (not (<= 3 z 4)))")
(lint-test "(or (and (eq? x 'a) (< y 1)) (and (eq? x 'b) (< z 2)) (and (eq? x 'a) (< w 2)))" "")
+ (lint-test "(or (not (= x y)) (not (= x z)))" " or: perhaps (or (not (= x y)) (not (= x z))) -> (not (= x y z))")
+ (lint-test "(or (not x) (< x 1))" " in (or (not x) (< x 1)), perhaps change (not x) to (not (real? x))")
+ (lint-test "(or (not x) (boolean? x))" " or: perhaps (or (not x) (boolean? x)) -> (boolean? x)")
+ (lint-test "(or (not x) (< x 1) y)" " in (or (not x) (< x 1) y), perhaps change (not x) to (not (real? x))")
+ (lint-test "(and x (x))" " in (and x (x)), perhaps change x to (procedure? x)")
+ (lint-test "(if x (x))" " in (if x (x)), perhaps change x to (procedure? x)")
+
(lint-test "(not (or (not x) (not y)))" " not: perhaps (not (or (not x) (not y))) -> (and x y)")
(lint-test "(not (or (not (< x y)) (not (equal? a b)) (not z)))"
" not: perhaps (not (or (not (< x y)) (not (equal? a b)) (not z))) -> (and (< x y) (equal? a b) z)")
@@ -87089,7 +87432,8 @@ etc
(lint-test "(not (and (not (< x y)) (not (equal? a b)) (not z)))"
" not: perhaps (not (and (not (< x y)) (not (equal? a b)) (not z))) -> (or (< x y) (equal? a b) z)")
(lint-test "(not (or (not x) (< y z) (not (< z x))))"
- " not: perhaps (not (or (not x) (< y z) (not (< z x)))) -> (and x (>= y z) (< z x))")
+ " in (and x (< z x)), perhaps change x to (real? x)
+ not: perhaps (not (or (not x) (< y z) (not (< z x)))) -> (and x (>= y z) (< z x))")
(lint-test "(not (and (> x 2) (< x 5)))" " not: perhaps (not (and (> x 2) (< x 5))) -> (not (> 5 x 2))")
(lint-test "(not (and (> x 2) (not z)))" " not: perhaps (not (and (> x 2) (not z))) -> (or (<= x 2) z)")
(lint-test "(not (> x 1))" " not: perhaps (not (> x 1)) -> (<= x 1)")
@@ -87164,48 +87508,49 @@ etc
(lint-test "(and (= x y) (= x z))" " and: perhaps (and (= x y) (= x z)) -> (= x y z)")
(lint-test "(and (< x y) (> z y))" " and: perhaps (and (< x y) (> z y)) -> (< x y z)")
(lint-test "(and (< x y) (< y (let ((z 1)) (display z) z)))" " and: display returns its first argument, so this could be omitted: z")
- (lint-test "(and (pair? x) (null? x))" " and: perhaps (and (pair? x) (null? x)) -> #f")
- (lint-test "(and (> x 1) (> x 2))" " and: perhaps (and (> x 1) (> x 2)) -> (> x 2)")
- (lint-test "(and (< x 1) (< x 2))" " and: perhaps (and (< x 1) (< x 2)) -> (< x 1)")
- (lint-test "(and (< x 1) (< 2 x))" " and: perhaps (and (< x 1) (< 2 x)) -> #f")
- (lint-test "(and (> x 1) (> 2 x))" " and: perhaps (and (> x 1) (> 2 x)) -> (> 2 x 1)")
- (lint-test "(and (integer? x) (exact? x))" " and: perhaps (and (integer? x) (exact? x)) -> (integer? x)")
- (lint-test "(and (integer? x) #t)" " and: perhaps (and (integer? x) #t) -> (integer? x)")
- (lint-test "(and (inexact? x) (real? x))" "") ; might be complex
- (lint-test "(and (infinite? x) (number? x))" " and: perhaps (and (infinite? x) (number? x)) -> (infinite? x)")
- (lint-test "(and (not (= x 1)) (not (= x 2)))" " and: perhaps (and (not (= x 1)) (not (= x 2))) -> (not (member x '(1 2) =))")
- (lint-test "(and (not (list? x)) (not (pair? x)))" " and: perhaps (and (not (list? x)) (not (pair? x))) -> (not (list? x))")
- (lint-test "(and (not (null? x)) (not (pair? x)))" " and: perhaps (and (not (null? x)) (not (pair? x))) -> (not (list? x))")
- (lint-test "(and (not (null? x)) (not (list? x)))" " and: perhaps (and (not (null? x)) (not (list? x))) -> (not (list? x))")
- (lint-test "(and (zero? x) (zero? y))" " and: perhaps (and (zero? x) (zero? y)) -> (= 0 x y)")
- (lint-test "(and (string? x) (string=? x \"\"))" " and: perhaps (and (string? x) (string=? x \"\")) -> (equal? x \"\")")
- (lint-test "(and (number? x) (= x 1.0))" " and: perhaps (and (number? x) (= x 1.0)) -> (memv x '(1 1.0))")
- (lint-test "(and (real? x) (= x 1))" " and: perhaps (and (real? x) (= x 1)) -> (memv x '(1 1.0))")
- (lint-test "(and (integer? x) (= x 1))" " and: perhaps (and (integer? x) (= x 1)) -> (eqv? x 1)")
- (lint-test "(and (integer? x) (= x y))" "")
- (lint-test "(and (complex? x) (= x y))" "")
- (lint-test "(and (symbol? x) (eq? x 'a))" " and: perhaps (and (symbol? x) (eq? x 'a)) -> (eq? x 'a)")
- (lint-test "(and (keyword? x) (eq? x :a))" " and: perhaps (and (keyword? x) (eq? x :a)) -> (eq? x :a)")
+ (lint-test "(and (pair? x) (null? x))" " and: perhaps (and (pair? x) (null? x)) -> #f")
+ (lint-test "(and (> x 1) (> x 2))" " and: perhaps (and (> x 1) (> x 2)) -> (> x 2)")
+ (lint-test "(and (< x 1) (< x 2))" " and: perhaps (and (< x 1) (< x 2)) -> (< x 1)")
+ (lint-test "(and (< x 1) (< 2 x))" " and: perhaps (and (< x 1) (< 2 x)) -> #f")
+ (lint-test "(and (> x 1) (> 2 x))" " and: perhaps (and (> x 1) (> 2 x)) -> (> 2 x 1)")
+ (lint-test "(and (integer? x) (exact? x))" " and: perhaps (and (integer? x) (exact? x)) -> (integer? x)")
+ (lint-test "(and (integer? x) #t)" " and: perhaps (and (integer? x) #t) -> (integer? x)")
+ (lint-test "(and (inexact? x) (real? x))" " and: perhaps (and (inexact? x) (real? x)) -> (and (real? x) (inexact? x))")
+ (lint-test "(and (infinite? x) (number? x))" " and: perhaps (and (infinite? x) (number? x)) -> (infinite? x)")
+ (lint-test "(and (not (= x 1)) (not (= x 2)))" " and: perhaps (and (not (= x 1)) (not (= x 2))) -> (not (member x '(1 2) =))")
+ (lint-test "(and (not (list? x)) (not (pair? x)))" " and: perhaps (and (not (list? x)) (not (pair? x))) -> (not (list? x))")
+ (lint-test "(and (not (null? x)) (not (pair? x)))" " and: perhaps (and (not (null? x)) (not (pair? x))) -> (not (list? x))")
+ (lint-test "(and (not (null? x)) (not (list? x)))" " and: perhaps (and (not (null? x)) (not (list? x))) -> (not (list? x))")
+ (lint-test "(and (zero? x) (zero? y))" " and: perhaps (and (zero? x) (zero? y)) -> (= 0 x y)")
+ (lint-test "(and (string? x) (string=? x \"\"))" " and: perhaps (and (string? x) (string=? x \"\")) -> (equal? x \"\")")
+ (lint-test "(and (number? x) (= x 1.0))" " and: perhaps (and (number? x) (= x 1.0)) -> (memv x '(1 1.0))")
+ (lint-test "(and (real? x) (= x 1))" " and: perhaps (and (real? x) (= x 1)) -> (memv x '(1 1.0))")
+ (lint-test "(and (integer? x) (= x 1))" " and: perhaps (and (integer? x) (= x 1)) -> (eqv? x 1)")
+ (lint-test "(and (integer? x) (= x y))" "")
+ (lint-test "(and (complex? x) (= x y))" "")
+ (lint-test "(and (symbol? x) (eq? x 'a))" " and: perhaps (and (symbol? x) (eq? x 'a)) -> (eq? x 'a)")
+ (lint-test "(and (keyword? x) (eq? x :a))" " and: perhaps (and (keyword? x) (eq? x :a)) -> (eq? x :a)")
(lint-test "(or (= x 1) (not (and (not (= y 2)) (not (= z 3)))))"
" or: perhaps (or (= x 1) (not (and (not (= y 2)) (not (= z 3))))) -> (or (= x 1) (= y 2) (= z 3))")
(lint-test "(and (= x 1) (not (or (not (= y 2)) (not (= z 3)))))"
" and: perhaps (and (= x 1) (not (or (not (= y 2)) (not (= z 3))))) -> (and (= x 1) (= y 2) (= z 3))")
- (lint-test "(and (pair? x) (not (list? x)))" " and: perhaps (and (pair? x) (not (list? x))) -> #f")
- (lint-test "(and (list? x) (not (pair? x)))" " and: perhaps (and (list? x) (not (pair? x))) -> (null? x)")
- (lint-test "(and (not (null? x)) (list? x))" " and: perhaps (and (not (null? x)) (list? x)) -> (pair? x)")
- (lint-test "(and (pair? x) (not (null? x)))" " and: perhaps (and (pair? x) (not (null? x))) -> (pair? x)")
- (lint-test "(and (pair? x) (not (string? x)))" " and: perhaps (and (pair? x) (not (string? x))) -> (pair? x)")
- (lint-test "(and (not (pair? x)) (symbol? x))" " and: perhaps (and (not (pair? x)) (symbol? x)) -> (symbol? x)")
- (lint-test "(and (symbol? x) (constant? x))" " and: perhaps (and (symbol? x) (constant? x)) -> (constant? x)")
- (lint-test "(or (symbol? x) (constant? x))" " or: perhaps (or (symbol? x) (constant? x)) -> (symbol? x)")
- (lint-test "(and (constant? x) (not (symbol? x)))" " and: perhaps (and (constant? x) (not (symbol? x))) -> #f")
+ (lint-test "(and (pair? x) (not (list? x)))" " and: perhaps (and (pair? x) (not (list? x))) -> #f")
+ (lint-test "(and (list? x) (not (pair? x)))" " and: perhaps (and (list? x) (not (pair? x))) -> (null? x)")
+ (lint-test "(and (not (null? x)) (list? x))" " and: perhaps (and (not (null? x)) (list? x)) -> (pair? x)")
+ (lint-test "(and (pair? x) (not (null? x)))" " and: perhaps (and (pair? x) (not (null? x))) -> (pair? x)")
+ (lint-test "(and (pair? x) (not (string? x)))" " and: perhaps (and (pair? x) (not (string? x))) -> (pair? x)")
+ (lint-test "(and (not (pair? x)) (symbol? x))" " and: perhaps (and (not (pair? x)) (symbol? x)) -> (symbol? x)")
+ (lint-test "(and (symbol? x) (constant? x))" " and: perhaps (and (symbol? x) (constant? x)) -> (constant? x)")
+ (lint-test "(or (symbol? x) (constant? x))" " or: perhaps (or (symbol? x) (constant? x)) -> (symbol? x)")
+ (lint-test "(and (constant? x) (not (symbol? x)))" " and: perhaps (and (constant? x) (not (symbol? x))) -> #f")
(lint-test "(and (not (eof-object? x)) (char=? x #\\a))" " and: perhaps (and (not (eof-object? x)) (char=? x #\\a)) -> (eqv? x #\\a)")
- (lint-test "(and (real? x) (not (rational? x)))" " and: perhaps (and (real? x) (not (rational? x))) -> (float? x)")
+ (lint-test "(and (real? x) (not (rational? x)))" " and: perhaps (and (real? x) (not (rational? x))) -> (float? x)")
(lint-test "(and (list? x) (not (proper-list? x)))" "")
(lint-test "(and (real? x) (not (integer? x)))" "")
- (lint-test "(and (not (complex? x)) (real? x))" " and: perhaps (and (not (complex? x)) (real? x)) -> #f")
+ (lint-test "(and (number? x) (inexact? x) (real? x))" " and: perhaps (and (number? x) (inexact? x) (real? x)) -> (and (real? x) (inexact? x))")
+ (lint-test "(and (not (complex? x)) (real? x))" " and: perhaps (and (not (complex? x)) (real? x)) -> #f")
(lint-test "(and (pair? x) (eq? x #<unspecified>))" " and: perhaps (and (pair? x) (eq? x #<unspecified>)) -> #f")
- (lint-test "(and (eq? x 'a) (pair? x))" " and: perhaps (and (eq? x 'a) (pair? x)) -> #f")
+ (lint-test "(and (eq? x 'a) (pair? x))" " and: perhaps (and (eq? x 'a) (pair? x)) -> #f")
(lint-test "(and (not (pair? x)) (or (not (pair? y)) (not (pair? z))))"
" and: perhaps (and (not (pair? x)) (or (not (pair? y)) (not (pair? z)))) -> (not (or (pair? x) (and (pair? y) (pair? z))))")
(lint-test "(or (not (pair? x)) (and (not (pair? y)) (not (pair? z))))"
@@ -87228,6 +87573,57 @@ etc
(lint-test "(and (equal? (caadr a) (caadr b)) (equal? (cdadr a) (cdadr b)))"
" and: perhaps (and (equal? (caadr a) (caadr b)) (equal? (cdadr a) (cdadr b))) -> (equal? (cadr a) (cadr b))")
+ (lint-test "(and t (string? t))" " and: perhaps (and t (string? t)) -> (string? t)")
+ (lint-test "(and t (string? t) v (string? v))" " and: perhaps (and t (string? t) v (string? v)) -> (and (string? t) (string? v))")
+ (lint-test "(and v (boolean? v) (not (equal? v w)))" " and: perhaps (and v (boolean? v) (not (equal? v w))) -> (and (eq? v #t) (not (equal? v w)))")
+ (lint-test "(and x (< x 2))" " in (and x (< x 2)), perhaps change x to (real? x)")
+ (lint-test "(and w x (substring s 0 x))" " in (and x (substring s 0 x)), perhaps change x to (integer? x)")
+ (lint-test "(and x (+ (log x) 1))" " in (and x (+ (log x) 1)), perhaps change x to (number? x)")
+ (lint-test "(and z x (+ (log x) 1))" " in (and z x (+ (log x) 1)), perhaps change x to (number? x)")
+ (lint-test "(when x (display (log x)))" " in (when x (display (log x))), perhaps change x to (number? x)")
+ (lint-test "(and x (substring s 0 x))" " in (and x (substring s 0 x)), perhaps change x to (integer? x)")
+ (lint-test "(and v (v 100))" " in (and v (v 100)), perhaps change v to (procedure? v) ; or maybe sequence?")
+ (lint-test "(when x (substring y x))" " in (when x (substring y x)), perhaps change x to (integer? x)")
+ (lint-test "(cond (x (+ 1 (abs x))) (else y))" " in (cond (x (+ 1 (abs x))) (else y)), perhaps change x to (real? x)")
+ (lint-test "(and t v (string? t) (string? v))"
+ " in (and t v (string? t) (string? v)), perhaps change (and ... t ... (string? t)) to (string? t)
+ in (and t v (string? t) (string? v)), perhaps change (and ... v ... (string? v)) to (string? v)")
+ (lint-test "(and (number? a) (positive? a))" " in (and (number? a) (positive? a)), perhaps change (number? a) to (real? a)")
+ (lint-test "(and (number? x) (< x 1))" " in (and (number? x) (< x 1)), perhaps change (number? x) to (real? x)")
+ (lint-test "(and (number? x) (even? x))" " in (and (number? x) (even? x)), perhaps change (number? x) to (integer? x)")
+
+ (lint-test "(cond ((number? x) (< x 1)) ((number? y) (display (abs y))))"
+ " in (cond ((number? x) (< x 1)) ((number? y) (display (abs y)))), perhaps change (number? x) to (real? x)
+ in (cond ((number? x) (< x 1)) ((number? y) (display (abs y)))), perhaps change (number? y) to (real? y)")
+ (lint-test "(cond ((number? y) (display (abs y))) ((number? x) (< x 1)))"
+ " in (cond ((number? y) (display (abs y))) ((number? x) (< x 1))), perhaps change (number? y) to (real? y)
+ in (cond ((number? y) (display (abs y))) ((number? x) (< x 1))), perhaps change (number? x) to (real? x)")
+ (lint-test "(cond ((number? (car x)) (< (car x) 1)) ((number? (vector-ref z y)) (display (abs (vector-ref z y)))))"
+ " in (cond ((number? (car x)) (< (car x) 1)) ((number? (vector-ref z y))..., perhaps change (number? (car x)) to (real? (car x))
+ in (cond ((number? (car x)) (< (car x) 1)) ((number? (vector-ref z y))..., perhaps change (number? (vector-ref z y)) to (real? (vector-ref z y))")
+
+ (lint-test "(and (number? x) (display (abs x)))" " in (and (number? x) (display (abs x))), perhaps change (number? x) to (real? x)")
+ (lint-test "(and (number? x) x (display (abs x)))" " in (and (number? x) x (display (abs x))), perhaps change x to (real? x)")
+ (lint-test "(and (number? (car x)) (display (abs (car x))))"
+ " in (and (number? (car x)) (display (abs (car x)))), perhaps change (number? (car x)) to (real? (car x))")
+ (lint-test "(and (number? (car x)) (display (abs (car x))) y)"
+ " in (and (number? (car x)) (display (abs (car x))) y), perhaps change (number? (car x)) to (real? (car x))")
+
+ (lint-test "(or (not (number? x)) (display (abs x)))"
+ " in (or (not (number? x)) (display (abs x))), perhaps change (not (number? x)) to (not (real? x))")
+ (lint-test "(or (not (number? (car x))) (display (abs (car x))))"
+ " in (or (not (number? (car x))) (display (abs (car x)))), perhaps change (not (number? (car x))) to (not (real? (car x)))")
+ (lint-test "(or (not (number? (car x))) (display (abs (car x))) y)"
+ " in (or (not (number? (car x))) (display (abs (car x))) y), perhaps change (not (number? (car x))) to (not (real? (car x)))")
+
+ (lint-test "(if (number? x) (display (abs x)))" " in (if (number? x) (display (abs x))), perhaps change (number? x) to (real? x)")
+ (lint-test "(if (not (number? x)) x (display (abs x)))"
+ " in (if (not (number? x)) x (display (abs x))), perhaps change (not (number? x)) to (not (real? x))")
+ (lint-test "(if (number? (car x)) (display (abs (car x))))"
+ " in (if (number? (car x)) (display (abs (car x)))), perhaps change (number? (car x)) to (real? (car x))")
+ (lint-test "(if (not (number? (car x))) x (display (abs (car x))))"
+ " in (if (not (number? (car x))) x (display (abs (car x)))), perhaps change (not (number? (car x))) to (not (real? (car x)))")
+
(lint-test "(string-append x (if y z) x)"
" string-append: in (string-append x (if y z) x), string-append's argument 2 should be a string, but #<unspecified> is untyped")
(lint-test "(string-append x (if y z w) x)" "")
@@ -87278,8 +87674,15 @@ etc
(if (not pure-s7) (lint-test "(current-output-port 123)" " current-output-port: too many arguments: (current-output-port 123)"))
(lint-test "(copy (owlet))" " copy: (copy (owlet)) could be (owlet): owlet is copied internally")
(lint-test "(gcd x '(asd))" " gcd: in (gcd x '(asd)), gcd's argument 2 should be rational, but '(asd) is a list?")
+
(lint-test "(string #\\null)" "")
(lint-test "(string (char->integer x))" " string: in (string (char->integer x)), string's argument should be a char, but (char->integer x) is an integer?")
+ (lint-test "(string (string-ref x 0))" " string: perhaps (string (string-ref x 0)) -> (substring x 0 1)")
+ (lint-test "(string (string-ref x 0) #\\a)" "")
+ (lint-test "(string (char-downcase (string-ref x 1)) (char-downcase (string-ref x 2)))"
+ " string: perhaps (string (char-downcase (string-ref x 1)) (char-downcase (string-ref x 2))) ->
+ (string-downcase (string (string-ref x 1) (string-ref x 2)))")
+
(lint-test "(+ 1 (if x 0 #()))" " +: in (+ 1 (if x 0 #())), +'s argument 2 should be a number, but #() is a vector?")
(lint-test "(+ 1 (if x #() 0))" " +: in (+ 1 (if x #() 0)), +'s argument 2 should be a number, but #() is a vector?")
(lint-test "(+ 1 (dynamic-wind (lambda () #f) (lambda () #()) (lambda () #f)))"
@@ -87342,7 +87745,9 @@ etc
(lint-test "(apply log x '())" " apply: perhaps (apply log x '()) -> (log x) apply: quote is not needed here: '()")
(lint-test "(apply f (append (list y z) a b))" " apply: perhaps (apply f (append (list y z) a b)) -> (apply f y z (append a b))")
(lint-test "(apply f (append (list y z)))" " apply: perhaps (apply f (append (list y z))) -> (apply f y z ()) apply: perhaps (append (list y z)) -> (list y z)")
- (lint-test "(apply f (append (list y z) a))" " apply: perhaps (apply f (append (list y z) a)) -> (apply f y z a)")
+ (lint-test "(apply f (append (list y z) a))"
+ " apply: perhaps (apply f (append (list y z) a)) -> (apply f y z a)
+ apply: perhaps (append (list y z) a) -> (cons y (cons z a))")
(lint-test "(apply map f (list x y))" " apply: perhaps (apply map f (list x y)) -> (map f x y)")
(lint-test "(apply string-append (map (lambda (x) (string-append x \" \")) input-files))"
" apply: perhaps (apply string-append (map (lambda (x) (string-append x \" \")) input-files)) -> (format #f \"~{~A ~}\" input-files)")
@@ -87351,12 +87756,20 @@ etc
(lint-test "(apply f y z (list a b))" " apply: perhaps (apply f y z (list a b)) -> (f y z a b)")
(lint-test "(apply append (map vector->list args))"
" apply: perhaps (apply append (map vector->list args)) -> (vector->list (apply append args))")
+ (lint-test "(apply f (cons a (cons b c)))" " apply: perhaps (apply f (cons a (cons b c))) -> (apply f a b c)")
+ (lint-test "(apply car x)" " apply: perhaps (apply car x) -> (car (car x))")
+ (lint-test "(apply string (map char-downcase x))"
+ " apply: perhaps, assuming x is a list, (apply string (map char-downcase x)) -> (string-downcase (apply string x))")
(lint-test "(eval '(+ 1 2))" " eval: perhaps (eval '(+ 1 2)) -> (+ 1 2)")
(lint-test "(eval 32)" " eval: this eval is pointless; perhaps (eval 32) -> 32")
(lint-test "(eval 'x)" " eval: perhaps (eval 'x) -> x")
(lint-test "(eval (string->symbol \"x\"))" " eval: perhaps (eval (string->symbol \"x\")) -> x")
- (lint-test "(eval (read (open-input-string expr)))" " eval: perhaps (eval (read (open-input-string expr))) -> (eval-string expr)")
+ (lint-test "(eval 'x env)" " eval: perhaps (eval 'x env) -> (env 'x)")
+ (lint-test "(eval (read (open-input-string expr)))" " eval: perhaps (eval (read (open-input-string expr))) -> (eval-string expr)")
+ (lint-test "(eval (call-with-input-string port read))" " eval: perhaps (eval (call-with-input-string port read)) -> (eval-string port)")
+ (lint-test "(eval '(begin (display (* x y)) z) env)" " eval: perhaps (eval '(begin (display (* x y)) z) env) -> (with-let env (display (* x y)) z)")
+ (lint-test "(eval (list '* 2 x))" " eval: perhaps (eval (list '* 2 x)) -> (* 2 (eval x))")
(lint-test "(with-let 123 123)" " with-let: with-let: first argument should be an environment: (with-let 123 123)")
(lint-test "(with-let (rootlet) 1)" "")
@@ -87369,6 +87782,8 @@ etc
(lint-test "(round (integer->char 96))"
" round: in (round (integer->char 96)), round's argument should be real, but (integer->char 96) is a char?
round: perhaps (integer->char 96) -> #\\`")
+ (lint-test "(integer->char (+ (char->integer #\\space) 215))"
+ " integer->char: perhaps (integer->char (+ (char->integer #\\space) 215)) -> #\\xf7")
(lint-test "(let ((v (make-vector 3))) (vector-set! v 3.14 #\\a))"
"let: perhaps (let ((v (make-vector 3))) (vector-set! v 3.14 #\\a)) -> (vector-set! (make-vector 3) 3.14 #\\a)
let: in (vector-set! v 3.14 #\\a), vector-set!'s argument 2 should be an integer, but 3.14 is real?")
@@ -87390,12 +87805,16 @@ etc
(lint-test "(char-position \"xyz\" \"asb\")" "")
(lint-test "(if (null? (cons x y)) 1.0 0.0)" " if: perhaps (if (null? (cons x y)) 1.0 0.0) -> 0.0")
(lint-test "(if (null (cdr x)) 0)" " if: misspelled 'null? in (null (cdr x))?")
+ (lint-test "(string-index path #\\/)" " string-index: perhaps (string-index path #\\/) -> (char-position #\\/ path)")
+ (lint-test "(string-index path #\\/ start end)" " string-index: perhaps (string-index path #\\/ start end) -> (char-position #\\/ path start end)")
+ (lint-test "(cons* x y)" " cons*: perhaps (cons* x y) -> (cons x y)")
(lint-test "(if (pair? (sin x)) 1.0 0.0)" " if: perhaps (if (pair? (sin x)) 1.0 0.0) -> 0.0")
(lint-test "(if (number? (sin x)) 1.0)" " if: perhaps (if (number? (sin x)) 1.0) -> 1.0")
(lint-test "(if (number? (car x)) 1.0)" "")
(lint-test "(if (real? (sin x)) 1.0)" "")
- (lint-test "(let ((list x)) (null? list))" " let: perhaps (let ((list x)) (null? list)) -> (null? x)")
-
+ (lint-test "(let ((list x)) (null? list))"
+ " let: perhaps (let ((list x)) (null? list)) -> (null? x)
+ let: assuming we see all set!s, (list x) is pointless: perhaps (let ((list x)) (null? list)) -> (let () (null? x))")
(lint-test "(set! x (real? (imag-part z)))" "set!: perhaps (real? (imag-part z)) -> #t set!: (real? (imag-part z)) is always #t")
(lint-test "(let ((x (char? (string-ref z y)))) x)"
" let: perhaps (char? (string-ref z y)) -> #t
@@ -87423,7 +87842,6 @@ etc
dynamic-wind: perhaps (lambda () (s7-version)) -> s7-version
dynamic-wind: perhaps (lambda () (list)) -> list")
(lint-test "(lambda args (apply + args))" " lambda: perhaps (lambda args (apply + args)) -> +")
- (lint-test "(define-macro (mac a) `(+ ,,a 1))" " mac: define-macro probably has too many unquotes: ({list} '+ (unquote a) 1)")
(lint-test "(let ((x 1) (y '(1 2))) `(,x , at y))"
" let: perhaps (let ((x 1) (y '(1 2))) ({list} x ({apply_values} y))) -> ({list} 1 ({apply_values} '(1 2)))")
@@ -87433,6 +87851,13 @@ etc
(lint-test "(define (:yyy a) a)" " define: keywords are constants :yyy")
(lint-test "(cons ((pair? x) 2) y)" " cons: cons's argument ((pair? x) 2) looks odd: pair? returns boolean? which is not applicable")
+ (lint-test "(let ((r (make-random-state 123 432))) (random 1.0 r))"
+ " let: make-random-state is deprecated; use random-state
+ let: perhaps (let ((r (make-random-state 123 432))) (random 1.0 r)) -> (random 1.0 (make-random-state 123 432))")
+ (lint-test "(let ((c (current-environment))) (defined? 'x c))"
+ " let: current-environment is deprecated; use curlet
+ let: perhaps (let ((c (current-environment))) (defined? 'x c)) -> (defined? 'x (current-environment))")
+
(lint-test "(let ((x 1) (y 2)) (if (= x 1) (begin (define (f1) x) (define (f2) (+ x 1)))) (f1 1))"
" let: f1 has too many arguments: (f1 1)
let: y not used, initially: 2 from let")
@@ -87450,6 +87875,7 @@ etc
" defmacro: defmacro is deprecated; perhaps (defmacro hi a ({list} '+ a b)) -> (define-macro (hi . a) ({list} '+ a b))")
(lint-test "(define)" " define: (define) makes no sense")
(lint-test "(define a)" " define: (define a) has no value?")
+ (lint-test "(let () (define (f a) (+ a b)) (define b 21) (f 1))" " let: b is used before it is defined: (define b 21)")
(lint-test "(define a . b)" " define: (define a . b) makes no sense")
(lint-test "(define a b c)" " define: (define a b c) has too many values?")
(lint-test "(define a a)" " define: this define is either not needed, or is an error: (define a a)")
@@ -87457,9 +87883,12 @@ etc
(lint-test "(define (f1 a) (abs a))" " f1: f1 could be (define f1 abs)")
(lint-test "(define (f1 a b) \"a docstring\" (log a b))" " f1: f1 could be (define f1 log)")
(lint-test "(let () (define (f1 a b) (* 2 (log a b))) (define (f2 a b) (f1 a b)) (f2 1 2))"
- " f2: f2 could be (define f2 f1) f1 is called only in f2")
+ " let: perhaps change f2 to a let:
+ (let () (define (f1 a b) (* 2 (log a b))) (define (f2 a b) (f1 a b)) (f2 1 2)) -> (... (let ((a 1) (b 2)) ...))
+ f2: f2 could be (define f2 f1) f1 is called only in f2")
(lint-test "(define (f x) (define aaa 1) (define aaa 2) (+ aaa 1))"
- " f: define variable aaa is redefined in the define body. Perhaps use set! instead: (set! aaa 2)
+ " f: perhaps (... (define aaa 1) (define aaa 2) (+ aaa 1)) -> (... (let ((aaa 1) (aaa 2)) ...))
+ f: define variable aaa is redefined in the define body. Perhaps use set! instead: (set! aaa 2)
f: aaa not used, initially: 1 from define")
(lint-test "(lambda ())" " lambda: lambda is messed up in (lambda ())")
(lint-test "(lambda (a b a) a)" " lambda: lambda parameter is repeated: (a b a) lambda: lambda parameter a is declared twice")
@@ -87500,11 +87929,12 @@ etc
let: f1 has too many arguments: (f1 2 3)")
(lint-test "(let () (define-macro (m1 a) a) (m1 2 3))" " let: m1 has too many arguments: (m1 2 3)")
(lint-test "(let () (define-macro (m2 b) `(let ((a 12)) (+ a ,b))) (let ((a 1) (+ *)) (+ a (m2 a))))"
- " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a, +")
+ " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a, +
+ let: assuming we see all set!s, (+ *) is pointless: perhaps (let ((a 1) (+ *)) (+ a (m2 a))) -> (let ((a 1)) (* a (m2 a)))")
(lint-test "(let () (define-macro (m3 b) `(let ((a 12)) (+ (symbol->value ,b) a))) (let ((a 1)) (+ a (m3 'a))))"
" let: possible problematic macro expansion: (m3 'a) could conceivably collide with subsequently defined 'a")
- (lint-test "(define pi (acos -1))" " define: (acos -1) is one of its many names, but pi a predefined constant in s7 pi: perhaps (acos -1) -> pi")
+ (lint-test "(define pi (acos -1))" " define: (acos -1) is one of its many names, but pi is a predefined constant in s7 pi: perhaps (acos -1) -> pi")
(lint-test "(+ x (atan 0 -1))" " +: perhaps (+ x (atan 0 -1)) -> (+ x pi)")
(lint-test "(define (f1) 32)" "")
(lint-test "(define (f2 a) a)" "")
@@ -87526,12 +87956,35 @@ etc
(lint-test "(define f4 (lambda (a b) a))" "")
(lint-test "(define f5 (lambda (a . b) a))" "")
- (lint-test "(define-macro (f1) 32)" " define-macro: perhaps (define-macro (f1) 32) -> (define f1 32)")
+ (lint-test "(define-macro (f1) 32)" " define-macro: perhaps (define-macro (f1) 32) -> (define f1 32) or (define (f1) 32)")
+ (lint-test "(define-macro (m1) 32)" " define-macro: perhaps (define-macro (m1) 32) -> (define m1 32) or (define (m1) 32)")
+ (lint-test "(define-macro (m2) 'a)" "")
+ (lint-test "(define-macro (m3) ''a)"
+ " define-macro: perhaps (define-macro (m3) ''a) -> (define m3 'a) or (define (m3) 'a)
+ m3: returns a list constant: ''a")
+ (lint-test "(define-macro (m4 a) `(abs ,a))" " define-macro: perhaps (define-macro (m4 a) ({list} 'abs a)) -> (define m4 abs)")
+ (lint-test "(define-macro (m5 a) `(log ,a 2))" " define-macro: perhaps (define-macro (m5 a) ({list} 'log a 2)) -> (define (m5 a) (log a 2))")
+ (lint-test "(define-macro (m6 a) `(+ ,a ,a))" "") ; here a might be (display 32) -- should happen twice
+ (lint-test "(define-macro (m7 a b) `(set! ,a ,b))" " define-macro: perhaps (define-macro (m7 a b) ({list} 'set! a b)) -> (define m7 set!)")
+ (lint-test "(define-macro (m8 a) `(lambda () ,a))" "")
+ (lint-test "(define-macro (m8 a) `(let () ,a))" "")
+ (lint-test "(define-macro (m9 a b) `(+ ,a (* ,b 2)))" "")
+ (lint-test "(define-macro (m10 a) `(+ ,a x))" " define-macro: perhaps (define-macro (m10 a) ({list} '+ a 'x)) -> (define (m10 a) (+ a x))")
+ (lint-test "(define-macro (m11) (- -1 (* -2 (expt 2 28))))"
+ " define-macro: perhaps (define-macro (m11) (- -1 (* -2 (expt 2 28)))) ->
+ (define m11 (- -1 (* -2 (expt 2 28)))) or (define (m11) (- -1 (* -2 (expt 2 28))))")
(lint-test "(define-macro (f2 a) a)" "")
(lint-test "(define-macro (f3 . a) a)" "")
(lint-test "(define-macro (f4 a b) a)" "")
(lint-test "(define-macro (f5 a . b) a)" "")
(lint-test "(define-macro (f6 a b . c) a)" "")
+ (lint-test "(define-macro (mac a) `(+ ,,a 1))"
+ " mac: define-macro probably has too many unquotes: ({list} '+ (unquote a) 1)")
+ (lint-test "(define-macro (m a) `(+ 1 a))"
+ " define-macro: missing comma? (define-macro (m a) '(+ 1 a)) m: returns a list constant: '(+ 1 a)")
+ (lint-test "(define-macro (m a) `(+ 1 ,a (* a 2)))"
+ " define-macro: perhaps (define-macro (m a) ({list} '+ 1 a '(* a 2))) -> (define (m a) (+ 1 a (* a 2)))
+ define-macro: missing comma? (define-macro (m a) ({list} '+ 1 a '(* a 2)))")
(lint-test "(let ((a 1)) (define (f1 b) (+ a b)) (f1 0))"
" let: perhaps (... (define (f1 b) (+ a b)) (f1 0)) -> (... (let ((b 0)) (+ a b)))
@@ -87541,7 +87994,8 @@ etc
(lint-test "(let f1 ((a 1)) (+ a (f1)))" " f1: f1 needs 1 argument: (f1)")
(lint-test "(let f1 ((a 1)) (f1 a 2))" " f1: f1 has too many arguments: (f1 a 2)")
(lint-test "(define f7 (let ((a 1)) (lambda () a)))" "")
- (lint-test "(let () (define f7 (let ((a 1)) (lambda () a))) (f7))" "")
+ (lint-test "(let () (define f7 (let ((a 1)) (lambda () a))) (f7))"
+ " let: perhaps (... (define f7 (let ((a 1)) (lambda () a))) (f7)) -> (... (let ((f7 (let ((a 1)) (lambda () a)))) ...))")
; (lint-test "(let () (define f7 (let ((a 1)) (lambda () a))) (f7 1))" "...")
(lint-test "(let () (define (f1) 32) (f1))" " let: perhaps (... (define (f1) 32) (f1)) -> (... 32)")
@@ -87640,8 +88094,9 @@ etc
(lint-test "(let () (define (f8 a) (+ a 1)) (string-ref (f8 1) 2))"
" let: perhaps (... (define (f8 a) (+ a 1)) (string-ref (f8 1) 2)) -> (... (string-ref (let ((a 1)) (+ a 1)) 2))
let: in (string-ref (f8 1) 2), string-ref's argument 1 should be a string, but (f8 1) is a number?")
- (lint-test "(begin (define (f11 x) (+ x 1)) (f11 (integer->char 2)))"
- " begin: in (f11 (integer->char 2)), f11's argument should be a number, but (integer->char 2) is a char?")
+ (lint-test "(begin (define (f11 x) (+ x 1)) (f11 (integer->char 32)))"
+ " begin: in (f11 (integer->char 32)), f11's argument should be a number, but (integer->char 32) is a char?
+ begin: perhaps (integer->char 32) -> #\\space")
(lint-test "(begin (define (f12 x) (log x 2)) (f12 \"asdf\"))"
" begin: in (f12 \"asdf\"), f12's argument should be a number, but \"asdf\" is a string?")
(lint-test "(+ a #\\a 2)" " +: in (+ a #\\a 2), +'s argument 2 should be a number, but #\\a is a char?")
@@ -87685,8 +88140,9 @@ etc
let: f8's parameter 2 is not used, but a value is passed: 2")
(lint-test "(let () (define (f1) 32) (set! f1 4) (+ 1 f1))" "")
(lint-test "(let () (define (f1) 32) (+ 1 f1))" " let: f1 is a procedure, but + in (+ 1 f1) wants a number?")
- (lint-test "(let () (define f10 (lambda (a) a)) (set! f10 (lambda (a b) (+ a b))) (f10 1 2))" " let: perhaps (lambda (a b) (+ a b)) -> +")
-
+ (lint-test "(let () (define f10 (lambda (a) a)) (set! f10 (lambda (a b) (+ a b))) (f10 1 2))"
+ " let: perhaps (... (define f10 (lambda (a) a)) (set! f10 (lambda (a b) (+ a b))) (f10 1 2)) -> (... (let ((f10 (lambda (a) a))) ...))
+ let: perhaps (lambda (a b) (+ a b)) -> +")
(lint-test "(begin (define (f20 x y) (+ y 1)) (f20 (+ z 1) z))" " begin: f20's parameter 1 is not used, but a value is passed: (+ z 1)")
(lint-test "(begin (define (f21 x y) (set! x 3) (+ y 1)) (f21 (+ z 1) z))"
" begin: f21's parameter 1's value is not used, but a value is passed: (+ z 1)")
@@ -87696,11 +88152,14 @@ etc
" f24: f23's parameter 1 is not used, but a value is passed: (+ x 1)")
(lint-test "(begin (define x 1) `#(,x))" ; this can be expanded: (lambda (x) #((unquote x)))
" begin: quasiquoted vectors are not supported: #((unquote x))")
- (lint-test "(begin (define-macro (m1 x y) `(+ ,y 1)) (m1 a b))" " begin: m1's parameter 1 is not used, but a value is passed: a")
+ (lint-test "(begin (define-macro (m1 x y) `(+ ,y 1)) (m1 a b))"
+ " begin: perhaps (define-macro (m1 x y) ({list} '+ y 1)) -> (define (m1 x y) (+ y 1))
+ begin: m1's parameter 1 is not used, but a value is passed: a")
(lint-test "(begin (define (f30 x) (if (> x 0) (f30 #() (- x 1)))) (f30 1))" " f30: f30 has too many arguments: (f30 #() (- x 1))")
(lint-test "(let () (define plus (case-lambda (() 0) ((x y) x) ((x y) (+ x y)) ((x y z) (+ x y z)) (args (apply + args)))) (plus))"
- " plus: repeated parameter list? (x y) in (case-lambda (() 0) ((x y) x) ((x y) (+ x y)) ((x y z) (+ x y z)) (args (apply + args)))")
+ " let: perhaps (... (define plus (case-lambda (() 0) ((x y) x) ((x y) (+ x y)) ((x y z)... -> (... (let ((plus ...)) ...))
+ plus: repeated parameter list? (x y) in (case-lambda (() 0) ((x y) x) ((x y) (+ x y)) ((x y z) (+ x y z)) (args (apply + args)))")
(lint-test "(case-lambda ((a b) (+ a b)))"
" case-lambda: perhaps (case-lambda ((a b) (+ a b))) -> (lambda (a b) (+ a b))")
(lint-test "(case-lambda \"a doc string\" ((a b) (+ a b)))"
@@ -87725,11 +88184,12 @@ etc
(lint-test "(define (f12 :key) :key)" " define: f12 parameter can't be a keyword: (f12 :key)")
(lint-test "(define :a 3)" " define: keywords are constants :a")
(lint-test "(let () (define most-positive-fixnum 32) most-positive-fixnum)"
- " let: most-positive-fixnum is a constant in s7: (define most-positive-fixnum 32)
- let: define returns the new value, so this could be omitted: most-positive-fixnum")
+ " let: perhaps (... (define most-positive-fixnum 32) most-positive-fixnum) -> (... (let ((most-positive-fixnum 32)) ...))
+ let: most-positive-fixnum is a constant in s7: (define most-positive-fixnum 32)
+ let: perhaps omit most-positive-fixnum and return 32")
(lint-test "(let () (define-constant __lt1__ 32) (set! __lt1__ 3) (+ __lt1__ 1))"
" let: can't set! __lt1__ in (set! __lt1__ 3) (it is a constant: 32)")
- (lint-test "(let () (define (f1 x) (+ x 1)) f1)" " let: define returns the new value, so this could be omitted: f1")
+ (lint-test "(let () (define (f1 x) (+ x 1)) f1)" " let: perhaps omit f1, and change (define (f1 x) ...) -> (lambda (x) ...)")
(lint-test "(let () (define (f1 x) (f2 (+ x 1))) (define (f2 x) x) (f1 3))" "")
(lint-test "(let () (define (f1 a) (let ((a (vector->list a))) (car a))) (f1 #(0)))"
" let: perhaps (... (define (f1 a) (let ((a (vector->list a))) (car a))) (f1 #(0))) -> (... (let ((a #(0))) (let ((a (vector->list a))) (car a))))
@@ -87737,11 +88197,14 @@ etc
(lint-test "(car (vector->list a))" " car: perhaps (car (vector->list a)) -> (vector-ref a 0)")
(lint-test "(null? (list))" " null?: perhaps (null? (list)) -> #t")
- (lint-test "(null? (list 1))" " null?: perhaps (null? (list 1)) -> #f")
+ (lint-test "(null? (list 1))" " null?: perhaps (null? (list 1)) -> #f null?: perhaps (list 1) -> '(1)")
(lint-test "(pair? (list))" " pair?: perhaps (pair? (list)) -> #f")
- (lint-test "(pair? (list 1))" " pair?: perhaps (pair? (list 1)) -> #t")
+ (lint-test "(pair? (list 1))" " pair?: perhaps (pair? (list 1)) -> #t pair?: perhaps (list 1) -> '(1)")
(lint-test "(proper-list? (list))" " proper-list?: perhaps (proper-list? (list)) -> #t proper-list?: (proper-list? (list)) is always #t")
- (lint-test "(proper-list? (list 1))" " proper-list?: perhaps (proper-list? (list 1)) -> #t proper-list?: (proper-list? (list 1)) is always #t")
+ (lint-test "(proper-list? (list 1))"
+ " proper-list?: perhaps (proper-list? (list 1)) -> #t
+ proper-list?: (proper-list? (list 1)) is always #t
+ proper-list?: perhaps (list 1) -> '(1)")
(lint-test "(or (list? e) (null? e))" " or: perhaps (or (list? e) (null? e)) -> (list? e)")
(lint-test "(or (list? e) (pair? e))" " or: perhaps (or (list? e) (pair? e)) -> (list? e)")
(lint-test "(or (proper-list? e) (null? e))" " or: perhaps (or (proper-list? e) (null? e)) -> (proper-list? e)")
@@ -87803,6 +88266,30 @@ etc
(lint-test "(and (pair? x) (+ x 1))" "in (and (pair? x) (+ x 1)), x is a pair, but + wants a number?")
(lint-test "(and (boolean? x) (not x))" " and: perhaps (and (boolean? x) (not x)) -> (not x)")
(lint-test "(and (boolean? x) (eq? x #f))" " and: perhaps (and (boolean? x) (eq? x #f)) -> (eq? x #f) and: perhaps (eq? x #f) -> (not x)")
+ (lint-test "(and (symbol? id) (not (member id x)))" " in (and (symbol? id) (not (member id x))), perhaps change (member id x) to (memq ...)")
+ (lint-test "(and (symbol? id) (not (equal? id x)))" " in (and (symbol? id) (not (equal? id x))), perhaps change (equal? id x) to (eq? ...)")
+ (lint-test "(and (boolean? id) (not (member id x)))" " in (and (boolean? id) (not (member id x))), perhaps change (member id x) to (memq ...)")
+ (lint-test "(and (number? id) (not (equal? id x)))" " in (and (number? id) (not (equal? id x))), perhaps change (equal? id x) to (eqv? ...)")
+ (lint-test "(and (symbol? id) (member id x))" " in (and (symbol? id) (member id x)), perhaps change (member id x) to (memq ...)")
+ (lint-test "(and (symbol? id) (memq id x))" "")
+ (lint-test "(and (symbol? id) (memv id x))" " in (and (symbol? id) (memv id x)), perhaps change (memv id x) to (memq ...)")
+ (lint-test "(and (symbol? id) (equal? id x))" " in (and (symbol? id) (equal? id x)), perhaps change (equal? id x) to (eq? ...)")
+ (lint-test "(and (boolean? id) (member id x))" " in (and (boolean? id) (member id x)), perhaps change (member id x) to (memq ...)")
+ (lint-test "(and (number? id) (equal? id x))" " in (and (number? id) (equal? id x)), perhaps change (equal? id x) to (eqv? ...)")
+ (lint-test "(and (integer? x) (number? y) (< y 3))"
+ " in (and (integer? x) (number? y) (< y 3)), perhaps change (number? y) to (real? y)")
+ (lint-test "(or (integer? x) (not (number? y)) (< y 3))"
+ " in (or (integer? x) (not (number? y)) (< y 3)), perhaps change (not (number? y)) to (not (real? y))")
+ (lint-test "(or (not (number? x)) (> x 2))" " in (or (not (number? x)) (> x 2)), perhaps change (not (number? x)) to (not (real? x))")
+ (lint-test "(or (integer? x) (not (number? y)) (< y 3))"
+ " in (or (integer? x) (not (number? y)) (< y 3)), perhaps change (not (number? y)) to (not (real? y))")
+ (lint-test "(and (integer? x) (number? y) (< y 3))"
+ " in (and (integer? x) (number? y) (< y 3)), perhaps change (number? y) to (real? y)")
+ (lint-test "(if (number? x) (member x y) 0)" " in (if (number? x) (member x y) 0), perhaps change (member x y) to (memv ...)")
+ (lint-test "(if (number? x) (< x y) 0)" " in (if (number? x) (< x y) 0), perhaps change (number? x) to (real? x)")
+ (lint-test "(if (not (number? x)) 0 (< x y))" " in (if (not (number? x)) 0 (< x y)), perhaps change (not (number? x)) to (not (real? x))")
+ (lint-test "(cond ((number? x) (< x y)) (else x))" " in (cond ((number? x) (< x y)) (else x)), perhaps change (number? x) to (real? x)")
+
(lint-test "(list? (make-list 1))" " list?: perhaps (list? (make-list 1)) -> #t list?: (list? (make-list 1)) is always #t")
(lint-test "(number? (+ 1 x))" " number?: perhaps (number? (+ 1 x)) -> #t number?: (number? (+ 1 x)) is always #t")
(lint-test "(number? (make-list 1))" " number?: perhaps (number? (make-list 1)) -> #f number?: (number? (make-list 1)) is always #f")
@@ -87823,7 +88310,7 @@ etc
(lint-test "(let ((x (list 23 1 3))) (reverse! x) x)" " let: reverse! might leave x in an undefined state; perhaps (set! x (reverse! x))")
; (lint-test "(if (and (list? x) (car x)) 3)" "")
(lint-test "(if (and (list? x) (not (null? x)) (car x)) 3)" "")
- (lint-test "(if x (map f x))" " if: perhaps (if x (map f x)) -> (if (sequence? x) (map f x))")
+ (lint-test "(if x (map f x))" " in (if x (map f x)), perhaps change x to (sequence? x)")
(lint-test "(let ((x 0)) (/ 21 x))" " let: perhaps (let ((x 0)) (/ 21 x)) -> (/ 21 0) let: x is 0, so (/ 21 x) is an error")
(lint-test "(cond ((> x 0) => abs) (else y))" " cond: in ((> x 0) => abs), (> x 0) returns a a boolean, but abs expects real?")
@@ -87834,8 +88321,10 @@ etc
(lint-test "(map (cut a) (list packages))" " map: perhaps (map (cut a) (list packages)) -> (list ((cut a) packages))")
(lint-test "(map abs (list packages))" " map: perhaps (map abs (list packages)) -> (list (abs packages))")
(lint-test "(map string->symbol (list \"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\"))"
- " map: perhaps (map string->symbol (list \"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\")) -> '(IOPAD IPAD OPAD HIGH LOW)")
+ " map: perhaps (map string->symbol (list \"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\")) -> '(IOPAD IPAD OPAD HIGH LOW)
+ map: perhaps (list \"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\") -> '(\"IOPAD\" \"IPAD\" \"OPAD\" \"HIGH\" \"LOW\")")
(lint-test "(list->string (list h1 h2))" " list->string: perhaps (list->string (list h1 h2)) -> (string h1 h2)")
+
(lint-test "(string-append (list->string (make-list indent #\\space)) str)"
" string-append: perhaps (list->string (make-list indent #\\space)) -> (make-string indent #\\space)")
(lint-test "(string-append (string #\\C) \"ZLl*()def\")"
@@ -87844,8 +88333,18 @@ etc
(lint-test "(string-append \"USER \" user (string #\\return) (string #\\newline))"
" string-append: perhaps (string-append \"USER \" user (string #\\return) (string #\\newline)) ->
(string-append \"USER \" user (string #\\return #\\newline))")
+ (lint-test "(define (indent->string indent) (string-append (make-string (quotient indent 8) #\\tab) (make-string (modulo indent 8) #\\space)))"
+ " indent->string: perhaps (string-append (make-string (quotient indent 8) #\\tab) (make-string... ->
+ (format #f \"~NC~NC\" (quotient indent 8) #\\tab (modulo indent 8) #\\space)")
+
(lint-test "(string=? (string (string-ref file-line 0)) \"*\")"
- " string=?: perhaps (string=? (string (string-ref file-line 0)) \"*\") -> (char=? (string-ref file-line 0) #\\*)")
+ " string=?: perhaps (string=? (string (string-ref file-line 0)) \"*\") -> (char=? (string-ref file-line 0) #\\*)
+ string=?: perhaps (string (string-ref file-line 0)) -> (substring file-line 0 1)")
+ (lint-test "(string=? (symbol->string a) (symbol->string b))" " string=?: perhaps (string=? (symbol->string a) (symbol->string b)) -> (eq? a b)")
+ (lint-test "(string=? (substring s 0 1) \"#\")" " string=?: perhaps (string=? (substring s 0 1) \"#\") -> (char=? (string-ref s 0) #\\#)")
+ (lint-test "(string=? \"#\" (string (string-ref s 0)))"
+ " string=?: perhaps (string=? \"#\" (string (string-ref s 0))) -> (char=? #\\# (string-ref s 0))
+ string=?: perhaps (string (string-ref s 0)) -> (substring s 0 1)")
(lint-test "(for-each display (list 1 a #\\newline))"
" for-each: perhaps (for-each display (list 1 a #\\newline)) -> (format () \"~A~A~A\" 1 a #\\newline)")
(lint-test "(for-each write-string (list a \"asdf\" (substring x 1)))"
@@ -87866,7 +88365,11 @@ etc
(lint-test "(let ()
(define (f11 a b) (if (positive? a) (+ a b) b))
(define (f14 x y) (if (positive? x) (+ x y) y))
- (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): f14 could be (define f14 f11)")
+ (+ (f11 1 2) (f14 1 2)))"
+ " let (line 3): perhaps embed f14:
+ (let () (define (f11 a b) (if (positive? a) (+ a b) b)) (define (f14 x y)... ->
+ (... (+ (f11 1 2) (let ((x 1) (y 2)) (if (positive? x) (+ x y) y))))
+ f14 (line 2): f14 could be (define f14 f11)")
(lint-test "(let ((x (let () (define (f11 a b) (if (positive? a) (+ a b) b)) (f11 1 2))))
(define (f14 x y) (if (positive? x) (+ x y) y))
(+ x (f14 1 2)))"
@@ -87876,20 +88379,34 @@ etc
(define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b))
(define (f14 x y) (if (positive? x) (+ x y) y))
(+ (f11 1 2) (f14 1 2)))"
- " let (line 1): perhaps (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b)) ->
+ " let (line 3): perhaps embed f14:
+ (let () (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b))... ->
+ (... (+ (f11 1 2) (let ((x 1) (y 2)) (if (positive? x) (+ x y) y))))
+ let (line 1): perhaps (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b)) ->
(define (f11 a b) (if (positive? a) (+ a b) b))")
(lint-test "(let ()
(define (f11 a b) (if (positive? a) (+ a b) b))
(define (f14 y x) (if (positive? x) (+ x y) y))
- (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 x y)")
+ (+ (f11 1 2) (f14 1 2)))"
+ " let (line 3): perhaps embed f14:
+ (let () (define (f11 a b) (if (positive? a) (+ a b) b)) (define (f14 y x)... ->
+ (... (+ (f11 1 2) (let ((y 1) (x 2)) (if (positive? x) (+ x y) y))))
+ f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 x y)")
(lint-test "(let ()
(define (f11 b a) (if (positive? a) (+ a b) b))
(define (f14 x y) (if (positive? x) (+ x y) y))
- (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 y x)")
+ (+ (f11 1 2) (f14 1 2)))"
+ " let (line 3): perhaps embed f14:
+ (let () (define (f11 b a) (if (positive? a) (+ a b) b)) (define (f14 x y)... ->
+ (... (+ (f11 1 2) (let ((x 1) (y 2)) (if (positive? x) (+ x y) y))))
+ f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 y x)")
(lint-test "(let ()
(define (f1 x) (set! x 32) (log x 2.0))
(define (f2 y) (set! y 32) (log y 2.0))
- (+ (f1 0) (f2 0)))" " f2 (line 2): f2 could be (define f2 f1)")
+ (+ (f1 0) (f2 0)))"
+ " let (line 3): perhaps embed f2:
+ (let () (define (f1 x) (set! x 32) (log x 2.0)) (define (f2 y) (set! y 32)... -> (... (+ (f1 0) (let ((y 0)) (set! y 32) (log y 2.0))))
+ f2 (line 2): f2 could be (define f2 f1)")
(lint-test "(let ()
(define (f11 a b) (if (positive? a) (+ a b) b))
(let ((z (if (positive? a1) (+ a1 b1) b1)))
@@ -87897,12 +88414,20 @@ etc
(lint-test "(let ()
(define (f11 a b) (if (positive? a) (+ a b) b))
(define f14 (lambda (x y) (if (positive? x) (+ x y) y)))
- (+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 x y)")
+ (+ (f11 1 2) (f14 1 2)))"
+ " let (line 3): the scope of f14 could be reduced:
+ (... (define f14 (lambda (x y) (if (positive? x) (+ x y) y))) (+ (f11 1 2) (f14 1 2))) ->
+ (... (let ((f14 (lambda (x y) (if (positive? x) (+ x y) y)))) (+ (f11 1 2) (f14 1 2))))
+ f14 (line 2): perhaps (if (positive? x) (+ x y) y) -> (f11 x y)")
(lint-test "(let ()
(define f11 (let () (lambda (a b) (if (positive? a) (+ a b) b))))
(define (f14 x y) (if (positive? x) (+ x y) y))
(+ (f11 1 2) (f14 1 2)))"
- " f11 (line 1): pointless let: (let () (lambda (a b) (if (positive? a) (+ a b) b))) -> (lambda (a b) (if (positive? a) (+ a b) b))
+ " let (line 3): perhaps (... (define f11 (let () (lambda (a b) (if (positive? a) (+ a b) b))))... ->
+ (... (let ((f11 (let () (lambda (a b) (if (positive? a) (+ a b) b))))) ...))
+ let (line 3): perhaps embed f14: (let () (define f11 (let () (lambda (a b) (if (positive? a) (+ a b) b))))... ->
+ (... (+ (f11 1 2) (let ((x 1) (y 2)) (if (positive? x) (+ x y) y))))
+ f11 (line 1): pointless let: (let () (lambda (a b) (if (positive? a) (+ a b) b))) -> (lambda (a b) (if (positive? a) (+ a b) b))
f14 (line 2): f14 could be (define f14 f11)")
(lint-test "(let ()
(define (f11 a b) (if (positive? a) (+ a b) b))
@@ -87910,7 +88435,8 @@ etc
(+ (f11 1 2) (f14 1 2)))" " f14 (line 2): perhaps (if (positive? x) (+ x (log y)) (log y)) -> (f11 x (log y))")
(lint-test "(let ()
(define union (let ((z 32)) (set! x (lambda (y) (+ z y))) (lambda args args)))
- (union 1 2))" "")
+ (union 1 2))"
+ " let (line 2): perhaps (... (define union (let ((z 32)) (set! x (lambda (y) (+ z y))) (lambda... -> (... (let ((union ...)) ...))")
(lint-test "(let ()
(define (f11 a b) (let ((z (+ a 1))) (if (positive? z) (+ a b) b)))
(define (f14 x y) (let ((w (+ x 1))) (if (positive? w) (+ x y) y)))
@@ -87960,21 +88486,32 @@ etc
(define (f20 a) (define (f20a b) (+ (* 2 b) a)) (f20a a))
(define (f21 x) (define (f21a c) (+ (* 2 c) x)) (f21a x))
(+ (f20 1) (f21 2)))"
- " let (line 1): perhaps (define (f20 a) (define (f20a b) (+ (* 2 b) a)) (f20a a)) -> (define (f20 a) (let ((b a)) (+ (* 2 b) a)))
- let (line 2): perhaps (define (f21 x) (define (f21a c) (+ (* 2 c) x)) (f21a x)) -> (define (f21 x) (let ((c x)) (+ (* 2 c) x)))
- f21 (line 2): f21 could be (define f21 f20)")
+ " let (line 1): perhaps (define (f20 a) (define (f20a b) (+ (* 2 b) a)) (f20a a)) -> (define (f20 a) (let ((b a)) (+ (* 2 b) a)))
+ let (line 2): perhaps (define (f21 x) (define (f21a c) (+ (* 2 c) x)) (f21a x)) -> (define (f21 x) (let ((c x)) (+ (* 2 c) x)))
+ f21 (line 2): f21 could be (define f21 f20)")
(lint-test "(let ()
(define (f20 a) (define f20a (lambda (b) (+ (* 2 b) a))) (f20a a))
(define (f21 x) (define f21a (lambda (c) (+ (* 2 c) x))) (f21a x))
- (+ (f20 1) (f21 2)))" " f21 (line 2): f21 could be (define f21 f20)")
+ (+ (f20 1) (f21 2)))"
+ " f20 (line 1): perhaps (... (define f20a (lambda (b) (+ (* 2 b) a))) (f20a a)) -> (... (let ((f20a (lambda (b) (+ (* 2 b) a)))) ...))
+ f21 (line 2): perhaps (... (define f21a (lambda (c) (+ (* 2 c) x))) (f21a x)) -> (... (let ((f21a (lambda (c) (+ (* 2 c) x)))) ...))
+ f21 (line 2): f21 could be (define f21 f20)")
(lint-test "(let ()
(define (f22 a) (lambda (b) (+ (* 2 b) a)))
(define (f23 x) (lambda (c) (+ (* 2 c) x)))
- (+ ((f22 1) 2) ((f23 2) 3)))" " f23 (line 2): f23 could be (define f23 f22)")
+ (+ ((f22 1) 2) ((f23 2) 3)))"
+ "let (line 3): perhaps embed f23:
+ (let () (define (f22 a) (lambda (b) (+ (* 2 b) a))) (define (f23 x)... ->
+ (... (+ ((f22 1) 2) ((let ((x 2)) (lambda (c) (+ (* 2 c) x))) 3)))
+ f23 (line 2): f23 could be (define f23 f22)")
(lint-test "(let ()
(define (f22 a) (lambda* ((b 21)) (+ (* 2 b) a)))
(define (f23 x) (lambda* ((c 21)) (+ (* 2 c) x)))
- (+ ((f22 1) 2) ((f23 2) 3)))" " f23 (line 2): f23 could be (define f23 f22)")
+ (+ ((f22 1) 2) ((f23 2) 3)))"
+ "let (line 3): perhaps embed f23:
+ (let () (define (f22 a) (lambda* ((b 21)) (+ (* 2 b) a))) (define (f23 x)... ->
+ (... (+ ((f22 1) 2) ((let ((x 2)) (lambda* ((c 21)) (+ (* 2 c) x))) 3)))
+ f23 (line 2): f23 could be (define f23 f22)")
(lint-test "(let ()
(define (f1 x) (abs (* 2 (+ (car x) 1))))
(define (f2 . x) (abs (* 2 (+ (car x) 1))))
@@ -87982,21 +88519,19 @@ etc
(lint-test "(let ()
(define (f1 . x) (abs (* 2 (+ (car x) 1))))
(define (f2 x) (abs (* 2 (+ (car x) 1))))
- (+ (f1 2) (f2 '(3))))" "") ; these should not match!
+ (+ (f1 2) (f2 '(3))))" ; these should not match!
+ " let (line 3): perhaps embed f2:
+ (let () (define (f1 . x) (abs (* 2 (+ (car x) 1)))) (define (f2 x) (abs (*... -> (... (+ (f1 2) (let ((x '(3))) (abs (* 2 (+ (car x) 1))))))")
(lint-test "(let ()
(define (f24 aa) (let ((z (+ aa 1))) (if (positive? z) (f24 (+ aa 1)) 0)))
(define (f25 x) (let ((w (+ x 1))) (if (positive? w) (f25 (+ x 1)) 0)))
(+ (f24 2) (f25 2)))"
- " f24 (line 1): (+ aa 1) is z in (let ((z (+ aa 1))) (if (positive? z) (f24 (+ aa 1)) 0))
- f25 (line 2): f25 could be (define f25 f24)
- f25 (line 2): (+ x 1) is w in (let ((w (+ x 1))) (if (positive? w) (f25 (+ x 1)) 0))")
+ " f25 (line 2): f25 could be (define f25 f24)")
(lint-test "(let ()
(define* (f26 (aa 1)) (let ((z (+ aa 1))) (if (positive? z) (f26 (+ aa 1)) 0)))
(define* (f27 (x 1)) (let ((w (+ x 1))) (if (positive? w) (f27 (+ x 1)) 0)))
(+ (f26 2) (f27 2)))"
- " f26 (line 1): (+ aa 1) is z in (let ((z (+ aa 1))) (if (positive? z) (f26 (+ aa 1)) 0))
- f27 (line 2): f27 could be (define f27 f26)
- f27 (line 2): (+ x 1) is w in (let ((w (+ x 1))) (if (positive? w) (f27 (+ x 1)) 0))")
+ " f27 (line 2): f27 could be (define f27 f26)")
(lint-test "(let ()
(define (f31 a b) (if (> a 0) (+ a b) b))
(define (f32 x y) (if (< 0 x) (+ x y) y))
@@ -88050,7 +88585,8 @@ etc
" define: perhaps (define (f11) (define (f12) (if (positive? a) (+ a b) (f12))) (f12)) ->
(define (f11) (if (positive? a) (+ a b) (f11)))")
- (lint-test "(let () (define (f40 x) (+ x 1)) (define (f41 y z) (y (+ z 1))) (f41 f40 2))" "")
+ (lint-test "(let () (define (f40 x) (+ x 1)) (define (f41 y z) (y (+ z 1))) (f41 f40 2))"
+ " let: perhaps change f41 to a let: (let () (define (f40 x) (+ x 1)) (define (f41 y z) (y (+ z 1))) (f41 f40 2)) -> (... (let ((y f40) (z 2)) ...))")
(lint-test "(let () (define (f41 y z) (y (+ z 1))) (f41 abs 2))"
" let: perhaps (... (define (f41 y z) (y (+ z 1))) (f41 abs 2)) -> (... (let ((y abs) (z 2)) (y (+ z 1))))")
(lint-test "(let () (define (f42 y z) (y (+ z 1))) (f42 (lambda (a) (+ a 1)) 2))"
@@ -88082,7 +88618,8 @@ etc
(lint-test "(let () (define (f60 x) (* 2 x)) (+ 1 (f60 y)))"
" let: perhaps (... (define (f60 x) (* 2 x)) (+ 1 (f60 y))) -> (... (+ 1 (let ((x y)) (* 2 x))))")
(lint-test "(let () (define f60 (let ((a (lambda (x) (* 2 x)))) a)) (+ 1 (f60 y)))"
- " f60: perhaps (let ((a (lambda (x) (* 2 x)))) a) -> (lambda (x) (* 2 x))")
+ " let: perhaps (... (define f60 (let ((a (lambda (x) (* 2 x)))) a)) (+ 1 (f60 y))) -> (... (let ((f60 (let ((a (lambda (x) (* 2 x)))) a))) ...))
+ f60: perhaps (let ((a (lambda (x) (* 2 x)))) a) -> (lambda (x) (* 2 x))")
(lint-test "(let ((x 2)) (let loop ((y x)) (if (positive? y) (loop (- y 1)) 0)))"
" let: perhaps (let ((x 2)) (let loop ((y x)) (if (positive? y) (loop (- y 1)) 0))) -> (let loop ((y 2)) (if (positive? y) (loop (- y 1)) 0))")
(lint-test "(let ((f60 (lambda (x) (* 2 x)))) (+ 1 (f60 y)))"
@@ -88097,13 +88634,17 @@ etc
(lint-test "(let () (define (get-xyzzy a) (+ 1 (car a)))
(define (set-xyzzy a b) (cons (+ a 1) b))
(set-xyzzy x (get-xyzzy y)))"
- "let: perhaps use dilambda and generalized set! for get-xyzzy and set-xyzzy:
+ "let (line 2): perhaps change set-xyzzy to a let:
+ (let () (define (get-xyzzy a) (+ 1 (car a))) (define (set-xyzzy a b) (cons... -> (... (let ((a x) (b (get-xyzzy y))) ...))
+ let: perhaps use dilambda and generalized set! for get-xyzzy and set-xyzzy:
replace (get-xyzzy ...) with (xyzzy ...) and (set-xyzzy ... b) with (set! (xyzzy ...) b)
(define xyzzy (dilambda (lambda (a) (+ 1 (car a))) (lambda (a b) (cons (+ a 1) b))))")
(lint-test "(let () (define (xyzzy-ref a) (+ 1 (car a)))
(define (xyzzy-set! a b) (cons (+ a 1) b))
(xyzzy-set! x (xyzzy-ref y)))"
- "let: perhaps use dilambda and generalized set! for xyzzy-ref and xyzzy-set!:
+ "let (line 2): perhaps change xyzzy-set! to a let:
+ (let () (define (xyzzy-ref a) (+ 1 (car a))) (define (xyzzy-set! a b)... -> (... (let ((a x) (b (xyzzy-ref y))) ...))
+ let: perhaps use dilambda and generalized set! for xyzzy-ref and xyzzy-set!:
replace (xyzzy-ref ...) with (xyzzy ...) and (xyzzy-set! ... b) with (set! (xyzzy ...) b)
(define xyzzy (dilambda (lambda (a) (+ 1 (car a))) (lambda (a b) (cons (+ a 1) b))))")
(lint-test "(let () (define (get-xyzzy) (+ 1 (car a)))
@@ -88115,37 +88656,101 @@ etc
(lint-test "(let () (define (xyzzy-ref xyzzy b) (+ b (car xyzzy)))
(define (xyzzy-set! xyzzy b c) (list (+ xyzzy c) b))
(xyzzy-set! obj (xyzzy-ref obj y) z))"
- "let: perhaps use dilambda and generalized set! for xyzzy-ref and xyzzy-set!:
+ "let (line 2): perhaps change xyzzy-set! to a let:
+ (let () (define (xyzzy-ref xyzzy b) (+ b (car xyzzy))) (define (xyzzy-set!... -> (... (let ((xyzzy obj) (b (xyzzy-ref obj y)) (c z)) ...))
+ let: perhaps use dilambda and generalized set! for xyzzy-ref and xyzzy-set!:
replace (xyzzy-ref ...) with (xyzzy ...) and (xyzzy-set! ... c) with (set! (xyzzy ...) c)
(define xyzzy (dilambda (lambda (_1_ b) (+ b (car _1_))) (lambda (_1_ b c) (list (+ _1_ c) b))))")
(lint-test "(let () (define (xyz-get-zy xyzzy b) (+ b (car xyzzy)))
(define (xyz-set-zy xyzzy b c) (list (+ xyzzy c) b))
(xyz-set-zy obj (xyz-get-zy obj y) z))"
- "let: perhaps use dilambda and generalized set! for xyz-get-zy and xyz-set-zy:
+ "let (line 2): perhaps change xyz-set-zy to a let:
+ (let () (define (xyz-get-zy xyzzy b) (+ b (car xyzzy))) (define... -> (... (let ((xyzzy obj) (b (xyz-get-zy obj y)) (c z)) ...))
+ let: perhaps use dilambda and generalized set! for xyz-get-zy and xyz-set-zy:
replace (xyz-get-zy ...) with (xyz-zy ...) and (xyz-set-zy ... c) with (set! (xyz-zy ...) c)
(define xyz-zy (dilambda (lambda (xyzzy b) (+ b (car xyzzy))) (lambda (xyzzy b c) (list (+ xyzzy c) b))))")
+ (lint-test "(let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f104 y))) (f105 (f104 3)))"
+ " let: perhaps change f105 to a let: (let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f104 y))) (f105... ->
+ (... (let ((y (f104 3))) ...))")
+ (lint-test "(let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f105 y))) (f105 (f104 3)))"
+ " let: perhaps change f105 to a named let: (let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f105 y))) (f105... ->
+ (... (let f105 ((y (f104 3))) ...))")
+ (lint-test "(let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f104 y))) (+ 1 (f105 (f104 3))))"
+ " let: perhaps embed f105: (let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f104 y))) (+ 1... ->
+ (... (+ 1 (let ((y (f104 3))) (+ y (f104 y)))))")
+ (lint-test "(let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f105 y))) (+ 1 (f105 (f104 3))))"
+ " let: perhaps embed f105: (let () (define (f104 x) (log x 8)) (define (f105 y) (+ y (f105 y))) (+ 1... ->
+ (... (+ 1 (let f105 ((y (f104 3))) (+ y (f105 y)))))")
+
(lint-test "(define (f70 a b) (let ((a a) (b b)) (+ a b)))"
" define: in (define (f70 a b) (let ((a a) (b b)) (+ a b))) this let binding is pointless: (a a)
define: in (define (f70 a b) (let ((a a) (b b)) (+ a b))) this let binding is pointless: (b b)
f70: perhaps (let ((a a) (b b)) (+ a b)) -> (+ a b)")
(lint-test "(let () (define f74 (lambda (b) (let loop ((c b)) (loop (+ c 1))))) (f74 2))"
- " let: perhaps (define f74 (lambda (b) (let loop ((c b)) (loop (+ c 1))))) -> (define (f74 c) (f74 (+ c 1)))")
+ " let: perhaps (... (define f74 (lambda (b) (let loop ((c b)) (loop (+ c 1))))) (f74 2)) ->
+ (... (let ((f74 (lambda (b) (let loop ((c b)) (loop (+ c 1)))))) ...))
+ let: perhaps (define f74 (lambda (b) (let loop ((c b)) (loop (+ c 1))))) -> (define (f74 c) (f74 (+ c 1)))")
(lint-test "(let () (define f74 (lambda (b) (let loop ((b b)) (loop (+ b 1))))) (f74 2))"
- " let: perhaps (define f74 (lambda (b) (let loop ((b b)) (loop (+ b 1))))) -> (define (f74 b) (f74 (+ b 1)))")
+ " let: perhaps (... (define f74 (lambda (b) (let loop ((b b)) (loop (+ b 1))))) (f74 2)) ->
+ (... (let ((f74 (lambda (b) (let loop ((b b)) (loop (+ b 1)))))) ...))
+ let: perhaps (define f74 (lambda (b) (let loop ((b b)) (loop (+ b 1))))) -> (define (f74 b) (f74 (+ b 1)))")
(lint-test "(let () (define f74 (lambda (b) (let loop ((b b) (c 0)) (loop (+ b c))))) (f74 2))"
- " loop: loop needs 2 arguments: (loop (+ b c))
+ " let: perhaps (... (define f74 (lambda (b) (let loop ((b b) (c 0)) (loop (+ b c))))) (f74 2)) -> (... (let ((f74 ...)) ...))
+ loop: loop needs 2 arguments: (loop (+ b c))
let: a toss-up -- perhaps (define f74 (lambda (b) (let loop ((b b) (c 0)) (loop (+ b c))))) -> (define* (f74 b (c 0)) (f74 (+ b c)))")
(lint-test "(let () (define (f1 x) (+ x 1)) (define (f2 a) (+ (a 1) 1)) (let ((b (f1 2))) (f2 f1) (+ b (f1 2) (f1 2) (f1 2))))" "")
(lint-test "(let () (define (f1 x) (+ x 1)) (let ((b (f1 2))) (+ b (f1 2) (f1 2) (f1 2))))" " let: f1's 'x parameter is always 2 (4 calls)")
- (let ((old-arity *report-func-as-arg-arity-mismatch*))
- (set! *report-func-as-arg-arity-mismatch* #t)
+ (lint-test "(let ((s s)) (- (expt s 3) (expt s 2)))"
+ " let: perhaps omit this useless let: (let ((s s)) (- (expt s 3) (expt s 2))) -> (- (expt s 3) (expt s 2))")
+ (lint-test "(let ((x x)) (vector-set! x 0 1) x)"
+ " let: perhaps omit this useless let: (let ((x x)) (vector-set! x 0 1) x) -> (begin (vector-set! x 0 1) x)")
+
+ (lint-test "(define (f x) (define y (g x)) (h (+ y x)))"
+ " f: perhaps (... (define y (g x)) (h (+ y x))) -> (... (let ((y (g x))) ...))")
+ (lint-test "(define (f x) (define y (g x)) (define z (h x)) (w (+ y x z)))"
+ " f: perhaps (... (define y (g x)) (define z (h x)) (w (+ y x z))) -> (... (let ((y (g x)) (z (h x))) ...))
+ f: the scope of z could be reduced: (... (define z (h x)) (w (+ y x z))) -> (... (let ((z (h x))) (w (+ y x z))))")
+ (lint-test "(define (f x) (define y (g x)) (define z (h y)) (w (+ y x z)))"
+ " f: perhaps (... (define y (g x)) (define z (h y)) (w (+ y x z))) -> (... (let* ((y (g x)) (z (h y))) ...))
+ f: the scope of z could be reduced: (... (define z (h y)) (w (+ y x z))) -> (... (let ((z (h y))) (w (+ y x z))))")
+ (lint-test "(define (f x) (define y (g x)) (define z (lambda (a) (if w (z (- a 1))))) (z (+ y x)))"
+ " f: perhaps (... (define y (g x)) (define z (lambda (a) (if w (z (- a 1))))) (z (+ y x))) ->
+ (... (letrec ((y (g x)) (z (lambda (a) (if w (z (- a 1)))))) ...))
+ f: the scope of z could be reduced: (... (define z (lambda (a) (if w (z (- a 1))))) (z (+ y x))) ->
+ (... (letrec ((z (lambda (a) (if w (z (- a 1)))))) (z (+ y x))))")
+ (lint-test "(define (f x) (define y (g x)) (define z (lambda (a) (if y (z (- a 1))))) (z (+ y x)))"
+ " f: perhaps (... (define y (g x)) (define z (lambda (a) (if y (z (- a 1))))) (z (+ y x))) ->
+ (... (letrec* ((y (g x)) (z (lambda (a) (if y (z (- a 1)))))) ...))
+ f: the scope of z could be reduced: (... (define z (lambda (a) (if y (z (- a 1))))) (z (+ y x))) ->
+ (... (letrec ((z (lambda (a) (if y (z (- a 1)))))) (z (+ y x))))")
+
+ (let-temporarily ((*report-shadowed-variables* #t))
+ (lint-test "(let ((f33 33)) (define f33 4) (g f33 1))"
+ " let: perhaps (... (define f33 4) (g f33 1)) -> (... (let ((f33 4)) ...))
+ let: let variable f33 in (define f33 4) shadows an earlier declaration
+ let: let variable f33 is redefined in the let body. Perhaps use set! instead: (set! f33 4)
+ let: f33 not used, initially: 33 from let")
+ (lint-test "(let ((f33 33)) (define (f33 x) (+ x 4)) (g f33 1))"
+ " let: let variable f33 in (define (f33 x) (+ x 4)) shadows an earlier declaration
+ let: let variable f33 is declared twice
+ let: f33 not used, initially: 33 from let")
+ (lint-test "(let ((f33 33)) (if (g x) (begin (define f33 4) (g f33)) 4))"
+ " let: begin variable f33 in (define f33 4) shadows an earlier declaration
+ let: let variable f33 is redefined in the let body. Perhaps use set! instead: (set! f33 4)
+ let: f33 not used, initially: 33 from let"))
+
+ (let-temporarily ((*report-func-as-arg-arity-mismatch* #t))
(lint-test "(let () (define (f43 x) (+ x 1)) (define (f44 y z) (y (+ z 1) abs)) (f44 f43 2))"
- " let: f44's parameter y is passed f43 and called (y (+ z 1) abs), but f43 takes only 1 argument")
+ " let: perhaps change f44 to a let:
+ (let () (define (f43 x) (+ x 1)) (define (f44 y z) (y (+ z 1) abs)) (f44 f43 2)) -> (... (let ((y f43) (z 2)) ...))
+ let: f44's parameter y is passed f43 and called (y (+ z 1) abs), but f43 takes only 1 argument")
(lint-test "(let () (define (f45 x) (+ x 1)) (define (f46 y z) (if z (y))) (f46 f45 2))"
- " let: f46's parameter y is passed f45 and called (y), but f45 needs 1 argument")
+ " let: perhaps change f46 to a let:
+ (let () (define (f45 x) (+ x 1)) (define (f46 y z) (if z (y))) (f46 f45 2)) -> (... (let ((y f45) (z 2)) ...))
+ let: f46's parameter y is passed f45 and called (y), but f45 needs 1 argument")
(lint-test "(let () (define (f47 y z) (y (+ z 1) abs)) (f47 abs 2))"
" let: perhaps (... (define (f47 y z) (y (+ z 1) abs)) (f47 abs 2)) -> (... (let ((y abs) (z 2)) (y (+ z 1) abs)))
let: f47's parameter y is passed abs and called (y (+ z 1) abs), but abs takes only 1 argument")
@@ -88158,9 +88763,25 @@ etc
(lint-test "(let () (define (f50 y z) (y (+ z 1))) (f50 (lambda (a b) (+ a 1)) 2))"
" let: perhaps (... (define (f50 y z) (y (+ z 1))) (f50 (lambda (a b) (+ a 1)) 2)) ->
(... (let ((y (lambda (a b) (+ a 1))) (z 2)) (y (+ z 1))))
- let: f50's parameter y is passed (lambda (a b) (+ a 1)) and called (y (+ z 1)), but (lambda (a b) (+ a 1)) needs 2 arguments")
- (set! *report-func-as-arg-arity-mismatch* old-arity))
+ let: f50's parameter y is passed (lambda (a b) (+ a 1)) and called (y (+ z 1)), but (lambda (a b) (+ a 1)) needs 2 arguments"))
+ (lint-test "(let () (define x 2) (display x) (set! y 32) (display y) (* y (log y)))"
+ " let: perhaps (... (define x 2) (display x) (set! y 32) (display y) (* y (log y))) -> (... (let ((x 2)) ...))
+ let: the scope of x could be reduced: (... (define x 2) (display x) ...) -> (... (let ((x 2)) (display x)) ...)")
+ (lint-test "(let () (display 32) (define x 2) (define (f101 y) (+ x y)) (display 41) (f101 2))"
+ " let: perhaps move x into f101's closure: (... (define x 2) (define (f101 y) (+ x y)) ...) ->
+ (... (define f101 (let ((x 2)) (lambda (y) (+ x y)))) ...)
+ x is used only in f101")
+ (lint-test "(let () (display 33) (define x 2) (define x (+ x y)) (display 43))"
+ " let: use set! to redefine x: (... (define x (+ x y)) ...) -> (... (set! x (+ x y)) ...)
+ let: let variable x is redefined in the let body. Perhaps use set! instead: (set! x (+ x y))
+ let: x not used, initially: (+ x y) from define")
+ (lint-test "(let () (display 34) (define x 2) (define f101 (lambda (y) (+ x y))) (display 41) (f101 2))"
+ " let: perhaps move x into f101's closure: (... (define x 2) (define f101 (lambda (y) (+ x y))) ...) ->
+ (... (define f101 (let ((x 2)) (lambda (y) (+ x y)))) ...)
+ let: the scope of f101 could be reduced:
+ (... (define f101 (lambda (y) (+ x y))) (display 41) (f101 2)) ->
+ (... (let ((f101 (lambda (y) (+ x y)))) (display 41) (f101 2)))")
(lint-test "(let ((x (read-byte)) (y (read-byte))) (- x y))"
" let: order of evaluation of let's bindings is unspecified, so (let ((x (read-byte)) (y (read-byte))) (- x y)) is trouble
let: perhaps (let ((x (read-byte)) (y (read-byte))) (- x y)) -> (- (read-byte) (read-byte))")
@@ -88201,6 +88822,8 @@ etc
(lint-test "(or (> 0 x) (> x 9))" " or: perhaps (or (> 0 x) (> x 9)) -> (not (<= 0 x 9))")
(lint-test "(or (>= 0 x) (>= x 9))" " or: perhaps (or (>= 0 x) (>= x 9)) -> (not (< 0 x 9))")
(lint-test "(or (> x 9) (< x 0))" " or: perhaps (or (> x 9) (< x 0)) -> (not (>= 9 x 0))")
+ (lint-test "(or (< x 3.0) (> x 3.0))" " or: perhaps (or (< x 3.0) (> x 3.0)) -> (not (= x 3.0))")
+ (lint-test "(or (< x 3.0) (= x 3.0))" " or: perhaps (or (< x 3.0) (= x 3.0)) -> (<= x 3.0) or: = can be troublesome with floats: (= x 3.0)")
(lint-test "(< 0 x 1)" "")
(lint-test "(< 1 x 1)" " <: it looks odd to have repeated arguments in (< 1 x 1) <: this comparison can't be true: (< 1 x 1) <: perhaps (< 1 x 1) -> #f")
@@ -88302,28 +88925,39 @@ etc
let: this could be omitted: (f i)
let: perhaps (do ((i 0 (+ i 1))) ((= i 10)) (f i)) -> (do ((i 0 (+ i 1))) ((= i 10)) (abs (* 2 i)))")
+ (lint-test "(apply env-channel
+ (make-env :envelope '(0 0 1 1)
+ :length (if (and (> (length args) 1) (number? (cadr args))) (cadr args)
+ (framples (if (> (length args) 2) (caddr args) (selected-sound))))) args)"
+ " apply (line 3): perhaps (apply env-channel (make-env ...) args) ->
+ (let ((_1_ (make-env ...))) (apply env-channel _1_ args))")
+ (let-temporarily ((*report-bloated-arg* 50))
+ (lint-test "(apply env-channel
+ (make-env :envelope '(0 0 1 1)
+ :length (if (and (> (length args) 1) (number? (cadr args))) (cadr args)
+ (framples (if (> (length args) 2) (caddr args) (selected-sound))))) args)" ""))
+
(lint-test "(let ((x 1)) (and x (< x 1)))"
- " in (and x (< x 1)), perhaps change (and x ...) to (and (real? x) ...)
+ " in (and x (< x 1)), perhaps change x to (real? x)
let: x is an integer, so (and x (< x 1)) -> (< x 1)")
(lint-test "(let ((x 1)) (and (< x 1) x))" "")
- (lint-test "(let ((x 1)) (and x (< x 1) x))" " let: x is an integer, so (and x (< x 1) x) -> (and (< x 1) x)")
+ (lint-test "(let ((x 1)) (and x (< x 1) x))"
+ " in (and x (< x 1)), perhaps change x to (real? x)
+ let: x is an integer, so (and x (< x 1) x) -> (and (< x 1) x)")
(lint-test "(let ((x 1)) (not x))" " let: perhaps (let ((x 1)) (not x)) -> (not 1) let: x is an integer, so (not x) -> #f")
(lint-test "(let ((l 1)) (+ l 1))" " let: perhaps (let ((l 1)) (+ l 1)) -> (+ 1 1) let: \"l\" is a really bad variable name")
(lint-test "(let ((let 1)) (+ let 1))" " let: perhaps (let ((let 1)) (+ let 1)) -> (+ 1 1) let: let variable named let is asking for trouble")
- (let ((old-report *report-bad-variable-names*))
- (set! *report-bad-variable-names* '(info data))
+ (let-temporarily ((*report-bad-variable-names* '(info data)))
(lint-test "(let ((data 1)) (+ data 32))"
" let: perhaps (let ((data 1)) (+ data 32)) -> (+ 1 32)
let: surely there's a better name for this variable than data")
(lint-test "(let ((info1 32) (info-1 31)) (+ info1 info-1))"
" let: perhaps (let ((info1 32) (info-1 31)) (+ info1 info-1)) -> (+ 32 31)
let: surely there's a better name for this variable than info-1
- let: surely there's a better name for this variable than info1")
- (set! *report-bad-variable-names* old-report))
+ let: surely there's a better name for this variable than info1"))
- (let ((old-report *report-built-in-functions-used-as-variables*))
- (set! *report-built-in-functions-used-as-variables* #t)
+ (let-temporarily ((*report-built-in-functions-used-as-variables* #t))
(lint-test "(let ((list 3)) (display list))"
" let: perhaps (let ((list 3)) (display list)) -> (display 3)
let: let variable named list is asking for trouble")
@@ -88338,9 +88972,49 @@ etc
" let: perhaps (... (define (f50 abs) (positive? abs)) (f50 -1)) -> (... (let ((abs -1)) (positive? abs)))
f50: f50 could be (define f50 positive?)
f50: f50 parameter named abs is asking for trouble")
- (set! *report-built-in-functions-used-as-variables* old-report))
+ (lint-test "(let append ((x y)) (if (null? x) () (append (cdr y))))" " let: let variable named append is asking for trouble"))
(lint-test "(error 'error \"ERROR SOMEWHERE UP TO HERE\")" " error: There's no need to shout: (error 'error \"ERROR SOMEWHERE UP TO HERE\")")
+ (lint-test "(define (f75) \"a string\")" " f75: returns a string constant: \"a string\"")
+ (lint-test "(define (f75) #(0 1 2 3))" " f75: returns a vector constant: #(0 1 2 3)")
+ (lint-test "(define (f75) '(0 1 2 3))" " f75: returns a list constant: '(0 1 2 3)")
+ (lint-test "(define (f75 x) (if x '(0 1 2 3) (+ x 1)))" " f75: returns a list constant: '(0 1 2 3)")
+
+ (lint-test "(define (f73 x) (let ((result 0)) (if (positive? x) (set! result 32) (set! result -1))))"
+ " f73: perhaps (if (positive? x) (set! result 32) (set! result -1)) -> (set! result (if (positive? x) 32 -1))
+ f73: result set, but not used: (set! result -1) (set! result 32)")
+ (lint-test "(do ((res 0 (+ res 1))) ((= res 3)) (set! res (+ res 32)))" "")
+ (lint-test "(begin (define res 0) (set! res (+ res 32)))" "")
+ (lint-test "(cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2)((string=? x \"c\") 3) ((string=? \"a\" x) 4))"
+ " cond: cond test (string=? \"a\" x) is never true: (cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2) ((string=? x \"c\") 3)...
+ cond: cond test is always false: ((string=? \"a\" x) 4)
+ cond: perhaps (cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2) ((string=? x \"c\") 3)... ->
+ (cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2) ((string=? x \"c\") 3))")
+ (lint-test "(cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2)((string=? x \"c\") 3) ((string=? x \"a\") 4))"
+ " cond: cond test (string=? x \"a\") is never true: (cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2) ((string=? x \"c\") 3)...
+ cond: cond test repeated: ((string=? x \"a\") 4)
+ cond: cond test is always false: ((string=? x \"a\") 4)
+ cond: perhaps (cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2) ((string=? x \"c\") 3)... ->
+ (cond ((string=? x \"a\") 1) ((string=? \"b\" x) 2) ((string=? x \"c\") 3))")
+ (lint-test "(cond ((< x 3) 1) ((> 2 x) 2) ((< x 1) 3))" "")
+ (let-temporarily ((*report-unused-parameters* #t))
+ (lint-test "(define (f74 x) (let ((lst (list 1 2 3 4 5 6 7 8))) (list-ref lst 2)))" " f74: x not used")
+ (lint-test "(let () (define (f75 x) (let ((lst (list 1 2 3 4 5 6 7 8))) (list-ref lst 2))) (f75 2))"
+ " let: perhaps (... (define (f75 x) (let ((lst (list 1 2 3 4 5 6 7 8))) (list-ref lst... ->
+ (... (let ((x 2)) (let ((lst (list 1 2 3 4 5 6 7 8))) (list-ref lst 2))))
+ f75: x not used
+ let: f75's parameter 1 is not used, but a value is passed: 2"))
+ (lint-test "(or (< x 3) (> 3 x))" " or: perhaps (or (< x 3) (> 3 x)) -> (< x 3)")
+ (lint-test "(and (< x 3) (> 3 x))" " and: perhaps (and (< x 3) (> 3 x)) -> (< x 3)")
+ (lint-test "(case x ((1) (f 1)) ((2) (f 2)) (else (f 3)))"
+ " case: perhaps (case x ((1) (f 1)) ((2) (f 2)) (else (f 3))) -> (f (case x ((1) 1) ((2) 2) (else 3)))")
+ (lint-test "(case x ((1) (f 1)) ((2) (f 2)) (else (error 'oops)))"
+ " case: perhaps (case x ((1) (f 1)) ((2) (f 2)) (else (error 'oops))) -> (f (case x ((1) 1) ((2) 2) (else (error 'oops))))")
+ (lint-test "(cond ((< x a) (f 1)) ((< x b) (f 2)) (else (f 3)))"
+ " cond: perhaps (cond ((< x a) (f 1)) ((< x b) (f 2)) (else (f 3))) -> (f (cond ((< x a) 1) ((< x b) 2) (else 3)))")
+ (lint-test "(- (cond ((char-position c dline id-pos)) (else 0)) 1)"
+ " -: perhaps (cond ((char-position c dline id-pos)) (else 0)) -> (or (char-position c dline id-pos) 0)")
+ (lint-test "(begin (cond ((find-sound v) => close-sound)) (display x))" "") ; check for side-effect confusion
(when (provided? 'snd)
(lint-test "(if (real? (oscil x)) 1.0 0.0)" " if: perhaps (if (real? (oscil x)) 1.0 0.0) -> 1.0")
diff --git a/s7webserver/jqconsole.min.js b/s7webserver/jqconsole.min.js
new file mode 100644
index 0000000..107e23d
--- /dev/null
+++ b/s7webserver/jqconsole.min.js
@@ -0,0 +1 @@
+(function(){var t,e,i,s,r,o,n,h,p,c,a,l,u,_,f,m,d,$,y,v,g,x,b,k,w,C,T,S,M,P,H,E,L,I,W,D,A,R=function(t,e){return function(){return t.apply(e,arguments)}},U=[].slice;t=jQuery;I=0;W=1;D=2;w=13;H=9;x=46;g=8;T=37;P=39;E=38;b=40;C=36;k=35;M=33;S=34;p="jqconsole-";r=""+p+"cursor";o=""+p+"header";c=""+p+"prompt";h=""+p+"old-prompt";n=""+p+"input";s=""+p+"blurred";y="keypress";m="<span/>";_="<div/>";f=":empty";L="\n";u=">>> ";l="... ";a=2;i=""+p+"ansi-";d="";$=/\[(\d*)(?:;(\d*))*m/;e=function(){t.prototype.COLORS=["black","red","green","yellow","blue","magenta","cyan","white"];function t(){this.stylize=R(this.stylize,this);this._closeSpan=R(this._closeSpan,this);this._openSpan=R(this._openSpan,this);this.getClasses=R(this.getClasses,this);this._style=R(this._style,this);this._color=R(this._color,this);this._remove=R(this._remove,this);this._append=R(this._append,this);this.klasses=[]}t.prototype._append=function(t){t=""+i+t;if(this.klasses.indexOf(t)===-1){return this.klasses.push(t)}};t.prototype._remove=function(){var t,e,s,r,o,n;s=1<=arguments.length?U.call(arguments,0):[];n=[];for(r=0,o=s.length;r<o;r++){e=s[r];if(e==="fonts"||e==="color"||e==="background-color"){n.push(this.klasses=function(){var s,r,o,n;o=this.klasses;n=[];for(s=0,r=o.length;s<r;s++){t=o[s];if(t.indexOf(e)!==i.length){n.push(t)}}return n}.call(this))}else{e=""+i+e;n.push(this.klasses=function(){var i,s,r,o;r=this.klasses;o=[];for(i=0,s=r.length;i<s;i++){t=r[i];if(t!==e){o.push(t)}}return o}.call(this))}}return n};t.prototype._color=function(t){return this.COLORS[t]};t.prototype._style=function(t){if(t===""){t=0}t=parseInt(t);if(isNaN(t)){return}switch(t){case 0:return this.klasses=[];case 1:return this._append("bold");case 2:return this._append("lighter");case 3:return this._append("italic");case 4:return this._append("underline");case 5:return this._append("blink");case 6:return this._append("blink-rapid");case 8:return this._append("hidden");case 9:return this._append("line-through");case 10:return this._remove("fonts");case 11:case 12:case 13:case 14:case 15:case 16:case 17:case 18:case 19:this._remove("fonts");return this._append("fonts-"+(t-10));case 20:return this._append("fraktur");case 21:return this._remove("bold","lighter");case 22:return this._remove("bold","lighter");case 23:return this._remove("italic","fraktur");case 24:return this._remove("underline");case 25:return this._remove("blink","blink-rapid");case 28:return this._remove("hidden");case 29:return this._remove("line-through");case 30:case 31:case 32:case 33:case 34:case 35:case 36:case 37:this._remove("color");return this._append("color-"+this._color(t-30));case 39:return this._remove("color");case 40:case 41:case 42:case 43:case 44:case 45:case 46:case 47:this._remove("background-color");return this._append("background-color-"+this._color(t-40));case 49:return this._remove("background-color");case 51:return this._append("framed");case 53:return this._append("overline");case 54:return this._remove("framed");case 55:return this._remove("overline")}};t.prototype.getClasses=function(){return this.klasses.join(" ")};t.prototype._openSpan=function(t){return'<span class="'+this.getClasses()+'">'+t};t.prototype._closeSpan=function(t){return""+t+"</span>"};t.prototype.stylize=function(t){var e,i,s,r,o,n;t=this._openSpan(t);s=0;while((s=t.indexOf(d,s))&&s!==-1){if(i=t.slice(s).match($)){n=i.slice(1);for(r=0,o=n.length;r<o;r++){e=n[r];this._style(e)}t=this._closeSpan(t.slice(0,s))+this._openSpan(t.slice(s+1+i[0].length))}else{s++}}return this._closeSpan(t)};return t}();A=function(t,e){return'<span class="'+t+'">'+(e||"")+"</span>"};v=function(){function i(i,s,r,n){this._HideComposition=R(this._HideComposition,this);this._ShowComposition=R(this._ShowComposition,this);this._UpdateComposition=R(this._UpdateComposition,this);this._EndComposition=R(this._EndComposition,this);this._StartComposition=R(this._StartComposition,this);this._CheckComposition=R(this._CheckComposition,this);this._ProcessMatch=R(this._ProcessMatch,this);this._HandleKey=R(this._HandleKey,this);this._HandleChar=R(this._HandleChar,this);this.isMobile=!!navigator.userAgent.match(/iPhone|iPad|iPod|Android/i);this.isIos=!!navigator.userAgent.match(/iPhone|iPad|iPod/i);this.isAndroid=!!navigator.userAgent.match(/Android/i);this.$window=t(window);this.header=s||"";this.prompt_label_main=typeof r==="string"?r:u;this.prompt_label_continue=n||l;this.indent_width=a;this.state=W;this.input_queue=[];this.input_callback=null;this.multiline_callback=null;this.history=[];this.history_index=0;this.history_new="";this.history_active=false;this.shortcuts={};this.$container=t("<div/>").appendTo(i);this.$container.css({top:0,left:0,right:0,bottom:0,position:"absolute",overflow:"auto"});this.$console=t('<pre class="jqconsole"/>').appendTo(this.$container);this.$console.css({margin:0,position:"relative","min-height":"100%","box-sizing":"border-box","-moz-box-sizing":"border-box","-webkit-box-sizing":"border-box"});this.$console_focused=true;this.$input_container=t(_).appendTo(this.$container);this.$input_container.css({position:"absolute",width:1,height:0,overflow:"hidden"});this.$input_source=this.isAndroid?t("<input/>"):t("<textarea/>");this.$input_source.attr({wrap:"off",autocapitalize:"off",autocorrect:"off",spellcheck:"false",autocomplete:"off"});this.$input_source.css({position:"absolute",width:2});this.$input_source.appendTo(this.$input_container);this.$composition=t(_);this.$composition.addClass(""+p+"composition");this.$composition.css({display:"inline",position:"relative"});this.matchings={openings:{},closings:{},clss:[]};this.ansi=new e;this._InitPrompt();this._SetupEvents();this.Write(this.header,o);t(i).data("jqconsole",this)}i.prototype.ResetHistory=function(){return this.SetHistory([])};i.prototype.ResetShortcuts=function(){return this.shortcuts={}};i.prototype.ResetMatchings=function(){return this.matchings={openings:{},closings:{},clss:[]}};i.prototype.Reset=function(){if(this.state!==W){this.ClearPromptText(true)}this.state=W;this.input_queue=[];this.input_callback=null;this.multiline_callback=null;this.ResetHistory();this.ResetShortcuts();this.ResetMatchings();this.$prompt.detach();this.$input_container.detach();this.$console.html("");this.$prompt.appendTo(this.$console);this.$input_container.appendTo(this.$container);this.Write(this.header,o);return void 0};i.prototype.GetHistory=function(){return this.history};i.prototype.SetHistory=function(t){this.history=t.slice();return this.history_index=this.history.length};i.prototype._CheckKeyCode=function(t){if(isNaN(t)){t=t.charCodeAt(0)}else{t=parseInt(t,10)}if(!(0<t&&t<256)||isNaN(t)){throw new Error("Key code must be a number between 0 and 256 exclusive.")}return t};i.prototype._LetterCaseHelper=function(t,e){e(t);if(65<=t&&t<=90){e(t+32)}if(97<=t&&t<=122){return e(t-32)}};i.prototype.RegisterShortcut=function(t,e){var i,s=this;t=this._CheckKeyCode(t);if(typeof e!=="function"){throw new Error("Callback must be a function, not "+e+".")}i=function(t){if(!(t in s.shortcuts)){s.shortcuts[t]=[]}return s.shortcuts[t].push(e)};this._LetterCaseHelper(t,i);return void 0};i.prototype.UnRegisterShortcut=function(t,e){var i,s=this;t=this._CheckKeyCode(t);i=function(t){if(t in s.shortcuts){if(e){return s.shortcuts[t].splice(s.shortcuts[t].indexOf(e),1)}else{return delete s.shortcuts[t]}}};this._LetterCaseHelper(t,i);return void 0};i.prototype.GetColumn=function(){var t;this.$prompt_right.detach();this.$prompt_cursor.text("");t=this.$console.text().split(L);this.$prompt_cursor.html(" ");this.$prompt_cursor.after(this.$prompt_right);return t[t.length-1].length};i.prototype.GetLine=function(){return this.$console.text().split(L).length-1};i.prototype.ClearPromptText=function(t){if(this.state===W){throw new Error("ClearPromptText() is not allowed in output state.")}this.$prompt_before.html("");this.$prompt_after.html("");this.$prompt_label.text(t?"":this._SelectPromptLabel(false));this.$prompt_left.text("");this.$prompt_right.text("");return void 0};i.prototype.GetPromptText=function(e){var i,s,r,o,n;if(this.state===W){throw new Error("GetPromptText() is not allowed in output state.")}if(e){this.$prompt_cursor.text("");n=this.$prompt.text();this.$prompt_cursor.html(" ");return n}else{o=function(e){var i;i=[];e.children().each(function(){return i.push(t(this).children().last().text())});return i.join(L)};s=o(this.$prompt_before);if(s){s+=L}r=this.$prompt_left.text()+this.$prompt_right.text();i=o(this.$prompt_after);if(i){i=L+i}return s+r+i}};i.prototype.SetPromptText=function(t){if(this.state===W){throw new Error("SetPromptText() is not allowed in output state.")}this.ClearPromptText(false);this._AppendPromptText(t);this._ScrollToEnd();return void 0};i.prototype.SetPromptLabel=function(t,e){this.prompt_label_main=t;if(e!=null){this.prompt_label_continue=e}return void 0};i.prototype.Write=function(e,i,s){var r;if(s==null){s=true}if(s){e=this.ansi.stylize(t(m).text(e).html())}r=t(m).html(e);if(i!=null){r.addClass(i)}return this.Append(r)};i.prototype.Append=function(e){var i;i=t(e).insertBefore(this.$prompt);this._ScrollToEnd();this.$prompt_cursor.detach().insertAfter(this.$prompt_left);return i};i.prototype.Input=function(t){var e,i,s,r,o=this;if(this.state===D){s=this.input_callback;r=this.multiline_callback;i=this.history_active;e=this.async_multiline;this.AbortPrompt();this.input_queue.unshift(function(){return o.Prompt(i,s,r,e)})}else if(this.state!==W){this.input_queue.push(function(){return o.Input(t)});return}this.history_active=false;this.input_callback=t;this.multiline_callback=null;this.state=I;this.$prompt.attr("class",n);this.$prompt_label.text(this._SelectPromptLabel(false));this.Focus();this._ScrollToEnd();return void 0};i.prototype.Prompt=function(t,e,i,s){var r=this;if(this.state!==W){this.input_queue.push(function(){return r.Prompt(t,e,i,s)});return}this.history_active=t;this.input_callback=e;this.multiline_callback=i;this.async_multiline=s;this.state=D;this.$prompt.attr("class",c+" "+this.ansi.getClasses());this.$prompt_label.text(this._SelectPromptLabel(false));this.Focus();this._ScrollToEnd();return void 0};i.prototype.AbortPrompt=function(){if(this.state!==D){throw new Error("Cannot abort prompt when not in prompt state.")}this.Write(this.GetPromptText(true)+L,h);this.ClearPromptText(true);this.state=W;this.input_callback=this.multiline_callback=null;this._CheckInputQueue();return void 0};i.prototype.Focus=function(){if(!this.IsDisabled()){this.$input_source.focus()}return void 0};i.prototype.SetIndentWidth=function(t){return this.indent_width=t};i.prototype.GetIndentWidth=function(){return this.indent_width};i.prototype.RegisterMatching=function(t,e,i){var s;s={opening_char:t,closing_char:e,cls:i};this.matchings.clss.push(i);this.matchings.openings[t]=s;return this.matchings.closings[e]=s};i.prototype.UnRegisterMatching=function(t,e){var i;i=this.matchings.openings[t].cls;delete this.matchings.openings[t];delete this.matchings.closings[e];return this.matchings.clss.splice(this.matchings.clss.indexOf(i),1)};i.prototype.Dump=function(){var e,i;e=this.$console.find("."+o).nextUntil("."+c).addBack();return function(){var s,r,o;o=[];for(s=0,r=e.length;s<r;s++){i=e[s];if(t(i).is("."+h)){o.push(t(i).text().replace(/^\s+/,">>> "))}else{o.push(t(i).text())}}return o}().join("")};i.prototype.GetState=function(){if(this.state===I){return"input"}else if(this.state===W){return"output"}else{return"prompt"}};i.prototype.Disable=function(){this.$input_source.attr("disabled",true);return this.$input_source.blur()};i.prototype.Enable=function(){return this.$input_source.attr("disabled",false)};i.prototype.IsDisabled=function(){return Boolean(this.$input_source.attr("disabled"))};i.prototype.MoveToStart=function(t){this._MoveTo(t,true);return void 0};i.prototype.MoveToEnd=function(t){this._MoveTo(t,false);return void 0};i.prototype.Clear=function(){this.$console.find("."+o).nextUntil("."+c).addBack().text("");this.$prompt_cursor.detach();return this.$prompt_after.before(this.$prompt_cursor)};i.prototype._CheckInputQueue=function(){if(this.input_queue.length){return this.input_queue.shift()()}};i.prototype._InitPrompt=function(){this.$prompt=t(A(n)).appendTo(this.$console);this.$prompt_before=t(m).appendTo(this.$prompt);this.$prompt_current=t(m).appendTo(this.$prompt);this.$prompt_after=t(m).appendTo(this.$prompt);this.$prompt_label=t(m).appendTo(this.$prompt_current);this.$prompt_left=t(m).appendTo(this.$prompt_current);this.$prompt_right=t(m).appendTo(this.$prompt_current);this.$prompt_right.css({position:"relative"});this.$prompt_cursor=t(A(r," "));this.$prompt_cursor.insertBefore(this.$prompt_right);this.$prompt_cursor.css({color:"transparent",display:"inline",zIndex:0});if(!this.isMobile){return this.$prompt_cursor.css("position","absolute")}};i.prototype._SetupEvents=function(){var t=this;if(this.isMobile){this.$console.click(function(e){e.preventDefault();return t.Focus()})}else{this.$console.mouseup(function(e){var i;if(e.which===2){return t.Focus()}else{i=function(){if(!window.getSelection().toString()){e.preventDefault();return t.Focus()}};return setTimeout(i,0)}})}this.$input_source.focus(function(){var e,i;t._ScrollToEnd();t.$console_focused=true;t.$console.removeClass(s);i=function(){if(t.$console_focused){return t.$console.removeClass(s)}};setTimeout(i,100);e=function(){if(t.isIos&&t.$console_focused){return t.$input_source.hide()}};return setTimeout(e,500)});this.$input_source.blur(function(){var e;t.$console_focused=false;if(t.isIos){t.$input_source.show()}e=function(){if(!t.$console_focused){return t.$console.addClass(s)}};return setTimeout(e,100)});this.$input_source.bind("paste",function(){var e;e=function(){if(t.in_composition){return}t._AppendPromptText(t.$input_source.val());t.$input_source.val("");return t.Focus()};return setTimeout(e,0)});this.$input_source.keypress(this._HandleChar);this.$input_source.keydown(this._HandleKey);this.$input_source.keydown(this._CheckComposition);this.$input_source.bind("compositionstart",this._StartComposition);this.$input_source.bind("compositionend",function(e){return setTimeout(function(){return t._EndComposition(e)},0)});if(this.isAndroid){this.$input_source.bind("input",this._StartComposition);return this.$input_source.bind("input",this._UpdateComposition)}else{return this.$input_source.bind("text",this._UpdateComposition)}};i.prototype._HandleChar=function(t){var e;if(this.state===W||t.metaKey||t.ctrlKey){return true}e=t.which;if(e===8||e===9||e===13){return false}this.$prompt_left.text(this.$prompt_left.text()+String.fromCharCode(e));this._ScrollToEnd();return false};i.prototype._HandleKey=function(e){var i;if(this.state===W){return true}i=e.keyCode||e.which;setTimeout(t.proxy(this._CheckMatchings,this),0);if(e.altKey){return true}else if(e.ctrlKey||e.metaKey){return this._HandleCtrlShortcut(i)}else if(e.shiftKey){switch(i){case w:this._HandleEnter(true);break;case H:this._Unindent();break;case E:this._MoveUp();break;case b:this._MoveDown();break;case M:this._ScrollPage("up");break;case S:this._ScrollPage("down");break;default:return true}return false}else{switch(i){case w:this._HandleEnter(false);break;case H:this._Indent();break;case x:this._Delete(false);break;case g:this._Backspace(false);break;case T:this._MoveLeft(false);break;case P:this._MoveRight(false);break;case E:this._HistoryPrevious();break;case b:this._HistoryNext();break;case C:this.MoveToStart(false);break;case k:this.MoveToEnd(false);break;case M:this._ScrollPage("up");break;case S:this._ScrollPage("down");break;default:return true}return false}};i.prototype._HandleCtrlShortcut=function(t){var e,i,s,r;switch(t){case x:this._Delete(true);break;case g:this._Backspace(true);break;case T:this._MoveLeft(true);break;case P:this._MoveRight(true);break;case E:this._MoveUp();break;case b:this._MoveDown();break;case k:this.MoveToEnd(true);break;case C:this.MoveToStart(true);break;default:if(t in this.shortcuts){r=this.shortcuts[t];for(i=0,s=r.length;i<s;i++){e=r[i];e.call(this)}return false}else{return true}}return false};i.prototype._HandleEnter=function(t){var e,i,s=this;this._EndComposition();if(t){return this._InsertNewLine(true)}else{i=this.GetPromptText();e=function(t){var e,r,o,n,h,c;if(t!==false){s.MoveToEnd(true);s._InsertNewLine(true);c=[];for(o=n=0,h=Math.abs(t);0<=h?n<h:n>h;o=0<=h?++n:--n){if(t>0){c.push(s._Indent())}else{c.push(s._Unindent())}}return c}else{r=s.state===I?"input":"prompt";s.Write(s.GetPromptText(true)+L,""+p+"old-"+r);s.ClearPromptText(true);if(s.history_active){if(!s.history.length||s.history[s.history.length-1]!==i){s.history.push(i)}s.history_index=s.history.length}s.state=W;e=s.input_callback;s.input_callback=null;if(e){e(i)}return s._CheckInputQueue()}};if(this.multiline_callback){if(this.async_multiline){return this.multiline_callback(i,e)}else{return e(this.multiline_callback(i))}}else{return e(false)}}};i.prototype._GetDirectionals=function(e){var i,s,r,o,n,h,p,c;o=e?this.$prompt_left:this.$prompt_right;i=e?this.$prompt_right:this.$prompt_left;r=e?this.$prompt_before:this.$prompt_after;s=e?this.$prompt_after:this.$prompt_before;h=e?t.proxy(this.MoveToStart,this):t.proxy(this.MoveToEnd,this);n=e?t.proxy(this._MoveLeft,this):t.proxy(this._MoveRight,this);c=e?"last":"first";p=e?"prependTo":"appendTo";return{$prompt_which:o,$prompt_opposite:i,$prompt_relative:r,$prompt_rel_opposite:s,MoveToLimit:h,MoveDirection:n,which_end:c,where_append:p}};i.prototype._VerticalMove=function(t){var e,i,s,r,o,n,h,p;p=this._GetDirectionals(t),s=p.$prompt_which,e=p.$prompt_opposite,i=p.$prompt_relative,o=p.MoveToLimit,r=p.MoveDirection;if(i.is(f)){return}n=this.$prompt_left.text().length;o();r();h=s.text();e.text(t?h.slice(n):h.slice(0,n));return s.text(t?h.slice(0,n):h.slice(n))};i.prototype._MoveUp=function(){return this._VerticalMove(true)};i.prototype._MoveDown=function(){return this._VerticalMove()};i.prototype._HorizontalMove=function(e,i){var s,r,o,n,h,p,c,a,l,u,_,d,$,y;y=this._GetDirectionals(i),h=y.$prompt_which,r=y.$prompt_opposite,n=y.$prompt_relative,o=y.$prompt_rel_opposite,d=y.which_end,_=y.where_append;a=i?/\w*\W*$/:/^\w*\W*/;l=h.text();if(l){if(e){$=l.match(a);if(!$){return}$=$[0];u=r.text();r.text(i?$+u:u+$);c=$.length;return h.text(i?l.slice(0,-c):l.slice(c))}else{u=r.text();r.text(i?l.slice(-1)+u:u+l[0]);return h.text(i?l.slice(0,-1):l.slice(1))}}else if(!n.is(f)){p=t(m)[_](o);p.append(t(m).text(this.$prompt_label.text()));p.append(t(m).text(r.text()));s=n.children()[d]().detach();this.$prompt_label.text(s.children().first().text());h.text(s.children().last().text());return r.text("")}};i.prototype._MoveLeft=function(t){return this._HorizontalMove(t,true)};i.prototype._MoveRight=function(t){return this._HorizontalMove(t)};i.prototype._MoveTo=function(t,e){var i,s,r,o,n,h,p;h=this._GetDirectionals(e),r=h.$prompt_which,i=h.$prompt_opposite,s=h.$prompt_relative,n=h.MoveToLimit,o=h.MoveDirection;if(t){p=[];while(!(s.is(f)&&r.text()==="")){n(false);p.push(o(false))}return p}else{i.text(this.$prompt_left.text()+this.$prompt_right.text());return r.text("")}};i.prototype._Delete=function(t){var e,i,s;i=this.$prompt_right.text();if(i){if(t){s=i.match(/^\w*\W*/);if(!s){return}s=s[0];return this.$prompt_right.text(i.slice(s.length))}else{return this.$prompt_right.text(i.slice(1))}}else if(!this.$prompt_after.is(f)){e=this.$prompt_after.children().first().detach();return this.$prompt_right.text(e.children().last().text())}};i.prototype._Backspace=function(e){var i,s,r;setTimeout(t.proxy(this._ScrollToEnd,this),0);s=this.$prompt_left.text();if(s){if(e){r=s.match(/\w*\W*$/);if(!r){return}r=r[0];return this.$prompt_left.text(s.slice(0,-r.length))}else{return this.$prompt_left.text(s.slice(0,-1))}}else if(!this.$prompt_before.is(f)){i=this.$prompt_before.children().last().detach();this.$prompt_label.text(i.children().first().text());return this.$prompt_left.text(i.children().last().text())}};i.prototype._Indent=function(){var t;return this.$prompt_left.prepend(function(){var e,i,s;s=[];for(t=e=1,i=this.indent_width;1<=i?e<=i:e>=i;t=1<=i?++e:--e){s.push(" ")}return s}.call(this).join(""))};i.prototype._Unindent=function(){var t,e,i,s,r;t=this.$prompt_left.text()+this.$prompt_right.text();r=[];for(e=i=1,s=this.indent_width;1<=s?i<=s:i>=s;e=1<=s?++i:--i){if(!/^ /.test(t)){break}if(this.$prompt_left.text()){this.$prompt_left.text(this.$prompt_left.text().slice(1))}else{this.$prompt_right.text(this.$prompt_right.text().slice(1))}r.push(t=t.slice(1))}return r};i.prototype._InsertNewLine=function(e){var i,s,r;if(e==null){e=false}r=this._SelectPromptLabel(!this.$prompt_before.is(f));i=t(m).appendTo(this.$prompt_before);i.append(t(m).text(r));i.append(t(m).text(this.$prompt_left.text()));this.$prompt_label.text(this._SelectPromptLabel(true));if(e&&(s=this.$prompt_left.text().match(/^\s+/))){this.$prompt_left.text(s[0])}else{this.$prompt_left.text("")}return this._ScrollToEnd()};i.prototype._AppendPromptText=function(t){var e,i,s,r,o,n;i=t.split(L);this.$prompt_left.text(this.$prompt_left.text()+i[0]);o=i.slice(1);n=[];for(s=0,r=o.length;s<r;s++){e=o[s];this._InsertNewLine();n.push(this.$prompt_left.text(e))}return n};i.prototype._ScrollPage=function(t){var e;e=this.$container[0].scrollTop;if(t==="up"){e-=this.$container.height()}else{e+=this.$container.height()}return this.$container.stop().animate({scrollTop:e},"fast")};i.prototype._ScrollToEnd=function(){var t;this.$container.scrollTop(this.$container[0].scrollHeight);t=this.$prompt_cursor.position();this.$input_container.css({left:t.left,top:t.top});return setTimeout(this.ScrollWindowToPrompt.bind(this),50)};i.prototype.ScrollWindowToPrompt=function(){var t,e,i,s,r,o;e=this.$prompt_cursor.height();o=this.$window.scrollTop();r=this.$window.scrollLeft();t=document.documentElement.clientHeight;s=this.$prompt_cursor.offset();i=s.top-2*e;if(this.isMobile&&(typeof orientation!=="undefined"&&orientation!==null)){if(o<s.top||o>s.top){return this.$window.scrollTop(i)}}else{if(o+t<s.top){return this.$window.scrollTop(s.top-t+e)}else if(o>i){return this.$window.scrollTop(s.top)}}};i.prototype._SelectPromptLabel=function(t){if(this.state===D){if(t){return" \n"+this.prompt_label_continue}else{return this.prompt_label_main}}else{if(t){return"\n "}else{return" "}}};i.prototype._Wrap=function(t,e,i){var s,r;r=t.html();s=r.slice(0,e)+A(i,r[e])+r.slice(e+1);return t.html(s)};i.prototype._WalkCharacters=function(t,e,i,s,r){var o,n,h;n=r?t.length:0;t=t.split("");h=function(){var e,i,s,o;if(r){s=t,t=2<=s.length?U.call(s,0,i=s.length-1):(i=0,[]),e=s[i++]}else{o=t,e=o[0],t=2<=o.length?U.call(o,1):[]}if(e){n=n+(r?-1:+1)}return e};while(o=h()){if(o===e){s++}else if(o===i){s--}if(s===0){return{index:n,current_count:s}}}return{index:-1,current_count:s}};i.prototype._ProcessMatch=function(e,i,s){var r,o,n,h,p,c,a,l,u,_,f,m,d=this;_=i?[e["closing_char"],e["opening_char"]]:[e["opening_char"],e["closing_char"]],h=_[0],l=_[1];f=this._GetDirectionals(i),n=f.$prompt_which,o=f.$prompt_relative;p=1;c=false;u=n.html();if(!i){u=u.slice(1)}if(s&&i){u=u.slice(0,-1)}m=this._WalkCharacters(u,h,l,p,i),a=m.index,p=m.current_count;if(a>-1){this._Wrap(n,a,e.cls);c=true}else{r=o.children();r=i?Array.prototype.reverse.call(r):r;r.each(function(s,r){var o,n;o=t(r).children().last();u=o.html();n=d._WalkCharacters(u,h,l,p,i),a=n.index,p=n.current_count;if(a>-1){if(!i){a--}d._Wrap(o,a,e.cls);c=true;return false}})}return c};i.prototype._CheckMatchings=function(e){var i,s,r,o,n,h,p;r=e?this.$prompt_left.text().slice(this.$prompt_left.text().length-1):this.$prompt_right.text()[0];p=this.matchings.clss;for(n=0,h=p.length;n<h;n++){i=p[n];t("."+i,this.$console).contents().unwrap()}if(s=this.matchings.closings[r]){o=this._ProcessMatch(s,true,e)}else if(s=this.matchings.openings[r]){o=this._ProcessMatch(s,false,e)}else if(!e){this._CheckMatchings(true)}if(e){if(o){return this._Wrap(this.$prompt_left,this.$prompt_left.html().length-1,s.cls)}}else{if(o){return this._Wrap(this.$prompt_right,0,s.cls)}}};i.prototype._HistoryPrevious=function(){if(!this.history_active){return}if(this.history_index<=0){return}if(this.history_index===this.history.length){this.history_new=this.GetPromptText()}return this.SetPromptText(this.history[--this.history_index])};i.prototype._HistoryNext=function(){if(!this.history_active){return}if(this.history_index>=this.history.length){return}if(this.history_index===this.history.length-1){this.history_index++;return this.SetPromptText(this.history_new)}else{return this.SetPromptText(this.history[++this.history_index])}};i.prototype._CheckComposition=function(t){var e;e=t.keyCode||t.which;if(e===229){if(this.in_composition){return this._UpdateComposition()}else{return this._StartComposition()}}};i.prototype._StartComposition=function(){if(this.in_composition){return}this.in_composition=true;this._ShowComposition();return setTimeout(this._UpdateComposition,0)};i.prototype._EndComposition=function(){if(!this.in_composition){return}this._HideComposition();this.$prompt_left.text(this.$prompt_left.text()+this.$composition.text());this.$composition.text("");this.$input_source.val("");return this.in_composition=false};i.prototype._UpdateComposition=function(t){var e,i=this;e=function(){if(!i.in_composition){return}return i.$composition.text(i.$input_source.val())};return setTimeout(e,0)};i.prototype._ShowComposition=function(){this.$composition.css("height",this.$prompt_cursor.height());this.$composition.empty();return this.$composition.appendTo(this.$prompt_left)};i.prototype._HideComposition=function(){return this.$composition.detach()};return i}();t.fn.jqconsole=function(t,e,i){return new v(this,t,e,i)};t.fn.jqconsole.JQConsole=v;t.fn.jqconsole.Ansi=e}).call(this);
\ No newline at end of file
diff --git a/selection.scm b/selection.scm
index 72948c5..5def667 100644
--- a/selection.scm
+++ b/selection.scm
@@ -28,32 +28,31 @@
(define swap-selection-channels
(let ((documentation "(swap-selection-channels) swaps the currently selected data's channels"))
(lambda ()
- (define find-selection-sound
- (lambda (not-this)
- (let ((scs (all-chans)))
- (call-with-exit
- (lambda (return)
- (map
- (lambda (snd chn)
- (if (and (selection-member? snd chn)
- (or (null? not-this)
- (not (equal? snd (car not-this)))
- (not (= chn (cadr not-this)))))
- (return (list snd chn))))
- (car scs)
- (cadr scs)))))))
-
- (if (selection?)
- (if (= (selection-chans) 2)
- (let* ((beg (selection-position))
- (len (selection-framples))
- (snd-chn0 (find-selection-sound ()))
- (snd-chn1 (find-selection-sound snd-chn0)))
- (if snd-chn1
- (swap-channels (car snd-chn0) (cadr snd-chn0) (car snd-chn1) (cadr snd-chn1) beg len)
- (error 'wrong-number-of-channels "swap-selection-channels needs two channels to swap")))
- (error 'wrong-number-of-channels "swap-selection-channels needs a stereo selection"))
- (error 'no-active-selection "swap-selection-channels needs a selection")))))
+ (let ((find-selection-sound
+ (lambda (not-this)
+ (let ((scs (all-chans)))
+ (call-with-exit
+ (lambda (return)
+ (map
+ (lambda (snd chn)
+ (if (and (selection-member? snd chn)
+ (or (null? not-this)
+ (not (equal? snd (car not-this)))
+ (not (= chn (cadr not-this)))))
+ (return (list snd chn))))
+ (car scs)
+ (cadr scs))))))))
+ (if (selection?)
+ (if (= (selection-chans) 2)
+ (let* ((beg (selection-position))
+ (len (selection-framples))
+ (snd-chn0 (find-selection-sound ()))
+ (snd-chn1 (find-selection-sound snd-chn0)))
+ (if snd-chn1
+ (swap-channels (car snd-chn0) (cadr snd-chn0) (car snd-chn1) (cadr snd-chn1) beg len)
+ (error 'wrong-number-of-channels "swap-selection-channels needs two channels to swap")))
+ (error 'wrong-number-of-channels "swap-selection-channels needs a stereo selection"))
+ (error 'no-active-selection "swap-selection-channels needs a selection"))))))
diff --git a/singer.scm b/singer.scm
index 85fc84e..e8b9eab 100644
--- a/singer.scm
+++ b/singer.scm
@@ -45,34 +45,30 @@
(pfun (let ((init (list 0.0 (* .8 (setup 3)))))
(for-each (lambda (b dat)
- (set! init (append init (list (- b beg))))
- (set! init (append init (list (* 1.0 (dat 3))))))
+ (set! init (append init (list (- b beg) (* 1.0 (dat 3))))))
(cdr begs)
data)
init))
(gfun (let ((init (list 0.0 0.0)))
(for-each (lambda (b dat)
- (set! init (append init (list (- b beg))))
- (set! init (append init (list (* 1.0 (dat 4))))))
+ (set! init (append init (list (- b beg) (* 1.0 (dat 4))))))
(cdr begs)
data)
init))
(nfun (let ((init (list 0.0 (* 1.0 (setup 5)))))
(for-each (lambda (b dat)
- (set! init (append init (list (- b beg))))
- (set! init (append init (list (* 1.0 (dat 5))))))
+ (set! init (append init (list (- b beg) (* 1.0 (dat 5))))))
(cdr begs)
data)
init))
(vfun (let ((init (list 0.0 (* 1.0 (setup 6)))))
(for-each (lambda (b dat)
- (set! init (append init (list (- b beg))))
- (set! init (append init (list (* 1.0 (dat 6))))))
+ (set! init (append init (list (- b beg) (* 1.0 (dat 6))))))
(cdr begs)
data)
init))
(noiseamps (let* ((len (length data))
- (v (make-float-vector len 0.0)))
+ (v (make-float-vector len)))
(do ((i 0 (+ i 1)))
((= i len))
(set! (v i) (* 1.0 ((data i) 5))))
@@ -86,8 +82,8 @@
(noise-env (make-env nfun :duration dur))
(ran-vib (make-rand-interp :frequency 10 :amplitude .02))
- (glot-datai (make-float-vector (* 2 (length glts)) 0.0))
- (glot-datar (make-float-vector (* 2 (length glts)) 0.0))
+ (glot-datai (make-float-vector (* 2 (length glts))))
+ (glot-datar (make-float-vector (* 2 (length glts))))
(tractlength+8 (+ tractlength 8))
(tractlength+1 (+ tractlength 1))
@@ -101,7 +97,7 @@
(tong-hump-pole 0.998)
(tong-tip-pole 0.998))
- (let ((shape-data (make-float-vector (* (length shps) tractlength+8) 0.0))
+ (let ((shape-data (make-float-vector (* (length shps) tractlength+8)))
(noselength-1 (- noselength 1))
(noselength-2 (- noselength 2))
@@ -114,10 +110,10 @@
(last-sfd -1)
(last-gfd -1)
- (glot-table (make-float-vector (+ 1 table-size) 0.0))
- (glot-table2 (make-float-vector (+ 1 table-size) 0.0))
- ;; (gn-table (make-float-vector (+ 1 table-size) 0.0)) ;(gn-gain 0.0) ;(gn-out 0.0) ;(gn-del (make-float-vector 4 0.0))
- ;; (gn-coeffs (make-float-vector 4 0.0)) ; in Perry's C code, these were set in setGlotNoiseFilter but it was never called!
+ (glot-table (make-float-vector (+ 1 table-size)))
+ (glot-table2 (make-float-vector (+ 1 table-size)))
+ ;; (gn-table (make-float-vector (+ 1 table-size))) ;(gn-gain 0.0) ;(gn-out 0.0) ;(gn-del (make-float-vector 4))
+ ;; (gn-coeffs (make-float-vector 4)) ; in Perry's C code, these were set in setGlotNoiseFilter but it was never called!
(table-increment 0.0)
(glot-refl-gain 0.7)
(pitch 400.0)
@@ -135,9 +131,9 @@
(inz1 0.0)
(inz2 0.0)
;; nasal tract acoustic tube structure
- (nose-coeffs (make-float-vector noselength 0.0))
- (nose1 (make-float-vector noselength 0.0))
- (nose2 (make-float-vector noselength 0.0))
+ (nose-coeffs (make-float-vector noselength))
+ (nose1 (make-float-vector noselength))
+ (nose2 (make-float-vector noselength))
(velum-pos 0.0)
(nose-last-minus-refl 0.0)
(nose-last-plus-refl 0.0)
@@ -172,19 +168,19 @@
(alpha3 0.0)
(noseposition 3)
- (target-radii (make-float-vector tractlength+8 0.0))
- (target-temp (make-float-vector tractlength+8 0.0))
- (radii-poles (make-float-vector tractlength+8 0.0))
- (radii-pole-gains (make-float-vector tractlength+8 0.0))
- (radii (make-float-vector tractlength+8 0.0))
+ (target-radii (make-float-vector tractlength+8))
+ (target-temp (make-float-vector tractlength+8))
+ (radii-poles (make-float-vector tractlength+8))
+ (radii-pole-gains (make-float-vector tractlength+8))
+ (radii (make-float-vector tractlength+8))
; the radii array contains the vocal tract section radii
; (tractlength-1 of them), then glottal reflection gain
; then lip reflection gain, then noise position, then noise gain,
; then noise pole angle, then noise pole radius,
; then noise pole angle2, then noise pole radius2, then velum opening radius
- (coeffs (make-float-vector tractlength 0.0))
- (dline1 (make-float-vector tractlength 0.0))
- (dline2 (make-float-vector tractlength 0.0)))
+ (coeffs (make-float-vector tractlength))
+ (dline1 (make-float-vector tractlength))
+ (dline2 (make-float-vector tractlength)))
(set! noisev (mus-xcoeffs noisef))
@@ -236,8 +232,8 @@
(let ((harms (floor (glot-datai 1)))
(temp1 0.0)
(temp 0.0)
- (sines (make-float-vector 200 0.0))
- (cosines (make-float-vector 200 0.0))
+ (sines (make-float-vector 200))
+ (cosines (make-float-vector 200))
(one-over-two-pi 0.159154943)
(two-pi-over-table-size (/ two-pi table-size))
(a (glot-datar 0))
@@ -256,7 +252,7 @@
(set! (sines 1) (* (+ ca2 (* (- sa2 (sin b2)) temp)) temp1 one-over-two-pi))
(set! (cosines 1) (* (- (* (- ca2 (cos b2)) temp) sa2) temp1 one-over-two-pi))))
(set! (sines 1) (+ (sines 1) (* (- (+ 0.75 (* (cos (* 2 a2)) 0.25)) ca2) one-over-two-pi)))
- (set! (cosines 1) (+ (cosines 1) (- (* (- sa2 (* (sin (* 2 a2)) 0.25)) one-over-two-pi) (* a 0.5))))
+ (set! (cosines 1) (- (+ (cosines 1) (* (- sa2 (* (sin (* 2 a2)) 0.25)) one-over-two-pi)) (* a 0.5)))
(do ((k 2 (+ k 1))
(ka2 (* 2 a2) (+ ka2 a2))
(ka1 a2 (+ ka1 a2))
@@ -272,7 +268,7 @@
(/ (* (- (cos ka1) 1.0) 0.5) (- k 1))
(/ (* (- (cos ka3) 1.0) 0.5) (+ k 1))))
(set! (sines k) (* (sines k) one-over-two-pi))
- (set! (cosines k) (+ (cosines k) (- (/ (sin ka2) k) (/ (* (sin ka1) 0.5) (- k 1)) (/ (* (sin ka3) 0.5) (+ k 1)))))
+ (set! (cosines k) (- (+ (cosines k) (/ (sin ka2) k)) (/ (* (sin ka1) 0.5) (- k 1)) (/ (* (sin ka3) 0.5) (+ k 1))))
(set! (cosines k) (* (cosines k) one-over-two-pi)))
(fill! glot-table 0.0)
(do ((j 0 (+ j 1))
@@ -355,30 +351,26 @@
(r (radii (+ tractlength 4)))
(t2 (radii (+ tractlength 5)))
(r2 (radii (+ tractlength 6))))
- (let (;; fricative noise generator (set noise angle and radius)
- (noise-angle (hz->radians temp1))
- (noise-angle2 (hz->radians t2))
- (noise-radius r)
- (noise-radius2 r2))
- (let ((noise-a (* -2.0 (cos (/ noise-angle formant-shift)) noise-radius))
- (noise-b (* noise-radius noise-radius))
- (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) noise-radius2))
- (noise-b2 (* noise-radius2 noise-radius2)))
+ (let ((noise-angle (hz->radians temp1)) ; fricative noise generator (set noise angle and radius)
+ (noise-angle2 (hz->radians t2)))
+ (let ((noise-a (* -2.0 (cos (/ noise-angle formant-shift)) r))
+ (noise-b (* r r))
+ (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) r2))
+ (noise-b2 (* r2 r2)))
(set! (noisev 0) (+ noise-a noise-a2))
(set! (noisev 1) (+ noise-b noise-b2 (* noise-a noise-a2)))
(set! (noisev 2) (+ (* noise-a2 noise-b) (* noise-b2 noise-a)))
(set! (noisev 3) (* noise-b2 noise-b)))))
-
+
(set! lip-radius (radii tractlength-2))
(set! velum-pos (radii (+ tractlength 7)))
(let ((leftradius (radii (- noseposition 2)))
- (velumradius velum-pos)
(rightradius (radii (- noseposition 1))))
- (let ((temp (max (- rightradius velumradius) 0.0)))
+ (let ((temp (max (- rightradius velum-pos) 0.0)))
;; nasal tract (set nasal shape)
(set! alpha1 (* leftradius leftradius))
(set! alpha2 (* temp temp)))
- (set! alpha3 (* velumradius velumradius)))
+ (set! alpha3 (* velum-pos velum-pos)))
(let ((temp1 (/ 2.0 (+ alpha1 alpha2 alpha3))))
(set! alpha1 (* alpha1 temp1))
(set! alpha2 (* alpha2 temp1))
@@ -416,7 +408,7 @@
(set! lt1 (one-pole lp (+ (dline1 2) temp)))
(set! (dline2 1) (+ temp (* (coeffs 1) (- glotsamp temp))))
- (set! temp (+ glotsamp (- (dline2 1) temp)))
+ (set! temp (- (+ glotsamp (dline2 1)) temp))
(set! temp (singer-filter 1 noseposition temp dline1 dline2 coeffs))
#|
(let ((x 0.0))
@@ -492,7 +484,7 @@
|#
(set! (dline2 tractlength-1) (+ last-lip-refl (* (coeffs tractlength-1) (- (dline1 tractlength-2) last-lip-refl))))
- (set! (dline1 tractlength-1) (+ (dline1 tractlength-2) (- (dline2 tractlength-1) last-lip-refl)))
+ (set! (dline1 tractlength-1) (- (+ (dline1 tractlength-2) (dline2 tractlength-1)) last-lip-refl))
(set! (dline1 tractlength-2) temp)
(if (not (= noise-gain 0.0))
(begin
diff --git a/snd-chn.c b/snd-chn.c
index ac4a0e6..97ac80e 100644
--- a/snd-chn.c
+++ b/snd-chn.c
@@ -1071,7 +1071,7 @@ void apply_x_axis_change(chan_info *cp)
for (i = 0; i < si->chans; i++)
if (cp != si->cps[i])
update_xs(si->cps[i], ap);
- si = free_sync_info(si);
+ free_sync_info(si);
}
else
{
@@ -1690,7 +1690,7 @@ static int make_graph_1(chan_info *cp, double cur_srate, graph_choice_t graph_ch
(*two_sided) = true;
}
}
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (graph_choice == NORMAL_GRAPH)
{
@@ -1848,7 +1848,7 @@ void make_partial_graph(chan_info *cp, mus_long_t beg, mus_long_t end)
draw_both_grf_points(cp->dot_size, ax, j, cp->time_graph_style);
}
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
#if (!USE_GTK)
display_selection(cp);
@@ -2000,7 +2000,7 @@ Xen make_graph_data(chan_info *cp, int edit_pos, mus_long_t losamp, mus_long_t h
}
}
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (data1)
return(Xen_list_2(xen_make_vct(data_size, data),
xen_make_vct(data_size, data1)));
@@ -4378,6 +4378,17 @@ static void display_channel_data_1(chan_info *cp, bool just_fft, bool just_lisp,
{
width = widget_width(channel_graph(cp));
height = widget_height(channel_graph(cp));
+
+#if USE_GTK
+ /* thanks to Tito Latini -- try to get reasonable size graphs even in a script (using --batch 1)
+ */
+ if (ss->batch_mode)
+ {
+ width = 600;
+ height = 400;
+ }
+#endif
+
if ((height > 5) && (width > 5))
display_channel_data_with_size(cp, width, height, 0, just_fft, just_lisp, just_time, use_incoming_cr);
}
@@ -4677,7 +4688,7 @@ void handle_cursor_with_sync(chan_info *cp, kbd_cursor_t redisplay)
si = snd_sync(sp->sync);
for (i = 0; i < si->chans; i++)
handle_cursor(si->cps[i], redisplay);
- si = free_sync_info(si);
+ free_sync_info(si);
}
else handle_cursor(cp, redisplay);
}
@@ -4699,7 +4710,7 @@ void cursor_moveto(chan_info *cp, mus_long_t samp)
cursor_sample(ncp) = samp;
handle_cursor(ncp, cursor_decision(ncp)); /* checks len */
}
- si = free_sync_info(si);
+ free_sync_info(si);
}
else
{
@@ -4782,7 +4793,7 @@ void sync_cursors(chan_info *cp, mus_long_t samp)
si = snd_sync(sp->sync);
for (i = 0; i < si->chans; i++)
cursor_sample(si->cps[i]) = samp;
- si = free_sync_info(si);
+ free_sync_info(si);
}
else cursor_sample(cp) = samp;
}
@@ -5935,7 +5946,7 @@ void graph_button_motion_callback(chan_info *cp, int x, int y, oclock_t time)
sono_update(si->cps[i]);
else update_graph(si->cps[i]);
}
- si = free_sync_info(si);
+ free_sync_info(si);
}
else
{
@@ -9072,7 +9083,7 @@ void write_transform_peaks(FILE *fd, chan_info *ucp)
}
}
}
- if (si) si = free_sync_info(si);
+ if (si) free_sync_info(si);
}
diff --git a/snd-completion.c b/snd-completion.c
index 314a7e7..5f4cb5e 100644
--- a/snd-completion.c
+++ b/snd-completion.c
@@ -638,7 +638,7 @@ static int find_indentation(char *str, int loc)
char *complete_listener_text(char *old_text, int end, bool *try_completion, char **to_file_text)
{
int len, i, k, spaces, text_pos = 0, cr_pos = 0;
- char *new_text = NULL, *file_text = NULL, *new_file = NULL;
+ char *new_text = NULL, *file_text = NULL;
len = strlen(old_text);
for (i = len - 1; i > 0; i--)
@@ -696,6 +696,7 @@ char *complete_listener_text(char *old_text, int end, bool *try_completion, char
if (old_text[i] == '\"')
{
+ char *new_file;
file_text = mus_strdup((char *)(old_text + i + 1));
new_file = filename_completer(NULL_WIDGET, file_text, NULL);
len = mus_strlen(new_file);
diff --git a/snd-dac.c b/snd-dac.c
index 6372809..c1dc22d 100644
--- a/snd-dac.c
+++ b/snd-dac.c
@@ -1249,7 +1249,7 @@ bool add_mix_to_play_list(mix_state *ms, chan_info *cp, mus_long_t beg_within_mi
(if (> samp 20000)
#f
(begin
- (set! samp (1+ samp))
+ (set! samp (+ samp 1))
(* .5 (oscil osc))))))) ; you can use explicit control panel accessors
*/
@@ -1475,7 +1475,7 @@ void play_channel_with_sync(chan_info *cp, mus_long_t start, mus_long_t end)
play_channels_1(si->cps, si->chans, si->begs, ends, IN_BACKGROUND, C_int_to_Xen_integer(AT_CURRENT_EDIT_POSITION), false, Xen_false, NULL, 0);
- si = free_sync_info(si);
+ free_sync_info(si);
if (ends) free(ends);
}
@@ -1500,7 +1500,7 @@ static dac_info *play_selection_1(play_process_t background, Xen stop_proc)
dp = play_channels_1(si->cps, si->chans, si->begs, ends, background, C_int_to_Xen_integer(AT_CURRENT_EDIT_POSITION), true, stop_proc, NULL, 0);
/* dp->dac_sample is the reader */
- si = free_sync_info(si); /* does not free samplers */
+ free_sync_info(si); /* does not free samplers */
free(ends);
}
}
@@ -3008,7 +3008,7 @@ If object is a string, it is assumed to be a file name: \n " play_example "\n
for (i = 0; i < si->chans; i++) si->begs[i] = start;
play_channels_1(si->cps, si->chans, si->begs, ends, background, edit_position, false, stop_func, S_play, edpos_argpos);
- si = free_sync_info(si);
+ free_sync_info(si);
if (ends) free(ends);
return(Xen_false);
}
diff --git a/snd-edits.c b/snd-edits.c
index a860708..1722aa0 100644
--- a/snd-edits.c
+++ b/snd-edits.c
@@ -2922,7 +2922,7 @@ static void backup_edit_list_1(chan_info *cp, bool freeing)
if (freeing)
top = fragment_free_list;
- old_ed = free_ed_list(old_ed, cp);
+ free_ed_list(old_ed, cp);
if (freeing)
{
while ((fragment_free_list) && (fragment_free_list != top))
@@ -3899,7 +3899,7 @@ static ed_list *change_samples_in_list(mus_long_t beg, mus_long_t num, int pos,
ed_list *del_state;
del_state = delete_section_from_list(beg, del_num, cp->edits[pos]);
new_state = insert_section_into_list(beg, num, del_state, &changed_f, origin, 1.0);
- del_state = free_ed_list(del_state, cp);
+ free_ed_list(del_state, cp);
}
else new_state = insert_section_into_list(beg, num, cp->edits[pos], &changed_f, origin, 1.0);
@@ -4928,8 +4928,6 @@ snd_fd *free_snd_fd_almost(snd_fd *sf)
{
if ((sf) && (!(sf->freed)))
{
- snd_data *sd;
-
if (sf->ramps)
{
if (READER_INCRS(sf)) free(READER_INCRS(sf));
@@ -4945,14 +4943,17 @@ snd_fd *free_snd_fd_almost(snd_fd *sf)
sf->mixes = (void *)free_reader_mixes((reader_mixes *)(sf->mixes));
reader_out_of_data(sf);
- sd = sf->current_sound;
- if ((sd) &&
- ((sd->type == SND_DATA_BUFFER) || (sd->type == SND_DATA_FILE)))
- {
- sd->inuse = false;
- if ((sd->copy) || (sd->free_me))
- sd = free_snd_data(sd);
- }
+ {
+ snd_data *sd;
+ sd = sf->current_sound;
+ if ((sd) &&
+ ((sd->type == SND_DATA_BUFFER) || (sd->type == SND_DATA_FILE)))
+ {
+ sd->inuse = false;
+ if ((sd->copy) || (sd->free_me))
+ free_snd_data(sd);
+ }
+ }
sf->current_sound = NULL;
if (sf->current_state)
{
@@ -5232,7 +5233,7 @@ static void previous_sound_1(snd_fd *sf)
prev_snd = sf->current_sound;
prev_snd->inuse = false;
sf->current_sound = NULL;
- if (prev_snd->copy) prev_snd = free_snd_data(prev_snd);
+ if (prev_snd->copy) free_snd_data(prev_snd);
}
if (sf->cbi == 0)
{
@@ -5326,7 +5327,7 @@ static void next_sound_1(snd_fd *sf)
nxt_snd = sf->current_sound;
nxt_snd->inuse = false;
sf->current_sound = NULL;
- if (nxt_snd->copy) nxt_snd = free_snd_data(nxt_snd);
+ if (nxt_snd->copy) free_snd_data(nxt_snd);
}
sf->cbi++;
if (sf->cbi >= (sf->current_state)->size)
@@ -5483,8 +5484,8 @@ void copy_then_swap_channels(chan_info *cp0, chan_info *cp1, int pos0, int pos1)
}
else
{
- if (e0) e0 = free_peak_env_info(e0);
- if (e1) e1 = free_peak_env_info(e1);
+ if (e0) free_peak_env_info(e0);
+ if (e1) free_peak_env_info(e1);
}
ripple_all(cp0, 0, 0);
@@ -5603,7 +5604,7 @@ io_error_t save_edits_and_update_display(snd_info *sp)
#ifndef _MSC_VER
if (access(sp->filename, W_OK))
{
- sa = free_axes_data(sa);
+ free_axes_data(sa);
if (ofile) free(ofile);
if (old_cursors) free(old_cursors);
if (vals)
@@ -5641,7 +5642,7 @@ io_error_t save_edits_and_update_display(snd_info *sp)
add_sound_data(sp->filename, sp, WITHOUT_INITIAL_GRAPH_HOOK);
restore_axes_data(sp, sa, mus_sound_duration(sp->filename), true);
sound_restore_marks(sp, ms);
- sa = free_axes_data(sa);
+ free_axes_data(sa);
for (i = 0; i < sp->nchans; i++)
cursor_sample(sp->chans[i]) = old_cursors[i];
free(old_cursors);
@@ -5727,7 +5728,7 @@ io_error_t save_edits_without_display(snd_info *sp, const char *new_name, mus_he
sf[k] = free_snd_fd(sf[k]);
free(sf);
sf = NULL;
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
if (vals)
{
free(vals);
@@ -5948,7 +5949,7 @@ bool undo_edit_with_sync(chan_info *cp, int count)
for (i = 0; i < si->chans; i++)
if (undo_edit(si->cps[i], count))
something_changed = true;
- si = free_sync_info(si);
+ free_sync_info(si);
return(something_changed);
}
else return(undo_edit(cp, count));
@@ -6016,7 +6017,7 @@ bool redo_edit_with_sync(chan_info *cp, int count)
for (i = 0; i < si->chans; i++)
if (redo_edit(si->cps[i], count))
something_changed = true;
- si = free_sync_info(si);
+ free_sync_info(si);
return(something_changed);
}
else return(redo_edit(cp, count));
@@ -8453,7 +8454,7 @@ history position to read (defaults to current position). snd can be a filename,
return(snd_no_such_channel_error(S_samples, snd, chn_n));
loc_sp = make_sound_readable(filename, false);
- cp = loc_sp->chans[chan];
+ /* cp = loc_sp->chans[chan]; */
v = mus_vct_make(len);
fvals = mus_vct_data(v);
mus_file_to_array(filename, chan, beg, len, fvals);
diff --git a/snd-fft.c b/snd-fft.c
index 7f24270..d412923 100644
--- a/snd-fft.c
+++ b/snd-fft.c
@@ -242,7 +242,7 @@ int find_and_sort_peaks(mus_float_t *buf, fft_peak *found, int num_peaks, mus_lo
inds = (mus_long_t *)calloc(num_peaks, sizeof(mus_long_t));
pks = 0;
- la = 0.0;
+ /* la = 0.0; */
ca = 0.0;
ra = 0.0;
minval = 0.00001;
@@ -313,7 +313,7 @@ int find_and_sort_transform_peaks(mus_float_t *buf, fft_peak *found, int num_pea
if (hop < 1) hop = 1;
pks = 0;
- la = 0.0;
+ /* la = 0.0; */
ca = 0.0;
ra = 0.0;
minval = 0.0;
diff --git a/snd-file.c b/snd-file.c
index 52a7ab6..00609a9 100644
--- a/snd-file.c
+++ b/snd-file.c
@@ -3755,7 +3755,7 @@ void g_init_file(void)
r = s7_make_symbol(s7, "real?");
s = s7_make_symbol(s7, "string?");
p = s7_make_symbol(s7, "pair?");
- l = s7_make_symbol(s7, "list");
+ l = s7_make_symbol(s7, "list?");
t = s7_t(s7);
z = s7_make_signature(s7, 2, b, p);
diff --git a/snd-gl.scm b/snd-gl.scm
index 5cc957d..cddad33 100644
--- a/snd-gl.scm
+++ b/snd-gl.scm
@@ -324,7 +324,7 @@
(glClearColor 1.0 1.0 1.0 1.0)
(glClear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
(let ((rl (channel->float-vector (left-sample) 512))
- (im (make-float-vector 512 0.0)))
+ (im (make-float-vector 512)))
(mus-fft rl im)
(let ((peak (* 2 (max (float-vector-peak rl) (float-vector-peak im)))))
(float-vector-scale! rl (/ 1.0 peak))
diff --git a/snd-gtk.scm b/snd-gtk.scm
index 0256364..c331db7 100644
--- a/snd-gtk.scm
+++ b/snd-gtk.scm
@@ -413,7 +413,7 @@
(let ((labelled-snds ()))
(define (kmg num)
- (cond ((<= num 0) "disk full!")
+ (cond ((<= num 0) (copy "disk full!"))
((<= num 1024) (format #f "space: ~10DK" num))
((> num 1048576) (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0))))
(else (format #f "space: ~6,3FM" (/ num 1024.0)))))
@@ -439,8 +439,7 @@
(if (not snd)
(snd-error "no sound found for disk space label")
(let* ((name-form ((sound-widgets) 10))
- (space (kmg (disk-kspace (file-name snd))))
- (new-label (gtk_label_new space)))
+ (new-label (gtk_label_new (kmg (disk-kspace (file-name snd))))))
(gtk_box_pack_start (GTK_BOX name-form) new-label #f #f 6)
(gtk_widget_show new-label)
(set! previous-label (list snd new-label))
@@ -476,8 +475,7 @@
(define snd-clock-icon
(lambda (snd hour)
- (let* ((window (GDK_WINDOW (gtk_widget_get_window ((sound-widgets snd) 8))))
- (cr (gdk_cairo_create window)))
+ (let ((cr (gdk_cairo_create (GDK_WINDOW (gtk_widget_get_window ((sound-widgets snd) 8))))))
(let ((bg (color->list *basic-color*)))
(cairo_set_source_rgb cr (car bg) (cadr bg) (caddr bg)))
(cairo_rectangle cr 0 0 16 16) ; icon bg
diff --git a/snd-gutils.c b/snd-gutils.c
index 33af5d4..e8031ee 100644
--- a/snd-gutils.c
+++ b/snd-gutils.c
@@ -1457,7 +1457,11 @@ void init_gtk(void)
" border-width: 0px;\n"
" background-color: #ffffff;\n"
"}\n"
+#if (!GTK_CHECK_VERSION(3, 18, 8))
"GtkButton#white_button:prelight { \n"
+#else
+ "GtkButton#white_button:hover { \n"
+#endif
" background-image: -gtk-gradient (linear, left top, right bottom, from(#ffffff), to(rgb(200, 225, 255)));\n"
"}\n",
-1, NULL);
@@ -1470,7 +1474,11 @@ void init_gtk(void)
" border-width: 0px;\n"
" background-color: #fffff0;\n"
"}\n"
+#if (!GTK_CHECK_VERSION(3, 18, 8))
"GtkButton#highlight_button:prelight { \n"
+#else
+ "GtkButton#highlight_button:hover { \n"
+#endif
" background-image: -gtk-gradient (linear, left top, right bottom, from(#fffff0), to(rgb(200, 225, 255)));\n"
"}\n",
-1, NULL);
@@ -1486,7 +1494,11 @@ void init_gtk(void)
" border-color: gray;\n"
" background-color: #fffff0;\n"
"}\n"
+#if (!GTK_CHECK_VERSION(3, 18, 8))
"GtkButton:prelight { \n"
+#else
+ "GtkButton:hover { \n"
+#endif
" background-image: -gtk-gradient (linear, left top, right bottom, from(#fffff0), to(rgb(200, 225, 255)));\n"
"}\n",
-1, NULL);
diff --git a/snd-lint.scm b/snd-lint.scm
new file mode 100644
index 0000000..a265129
--- /dev/null
+++ b/snd-lint.scm
@@ -0,0 +1,176 @@
+;;; Snd extensions for lint
+
+(require lint.scm)
+;;; *lint* is the lint environment, so everything in lint.scm is accessible here
+
+;;; --------------------------------
+;;; this sends lint's output to the Snd repl's widget
+(define (snd-lint file)
+ (lint file (openlet
+ (inlet :name "lint-output-port"
+ :format (lambda (p str . args) (snd-print (apply format #f str args)))
+ :write (lambda (obj p) (snd-print (object->string obj #t)))
+ :display (lambda (obj p) (snd-print (object->string obj #f)))
+ :write-string (lambda (str p) (snd-print str))
+ :write-char (lambda (ch p) (snd-print (string ch)))
+ :newline (lambda (p) (snd-print (string #\newline)))
+ :close-output-port (lambda (p) #f)
+ :flush-output-port (lambda (p) #f)))))
+
+
+;;; ---------------- deprecated funcs ----------------
+;;; Snd deprecated funcs, to be reported by lint
+
+(let ((deprecated-ops '((data-format . sample-type)
+ (mus-sound-frames . mus-sound-framples)
+ (mus-sound-data-format . mus-sound-sample-type)
+ (mus-data-format-name . mus-sample-type-name)
+ (mus-data-format->string . mus-sample-type->string))))
+
+ (define (snd-lint-deprecate caller head form env)
+ ((*lint* 'lint-format) "~A is deprecated; use ~A" caller head (cond ((assq head deprecated-ops) => cdr))))
+
+ (for-each (lambda (op)
+ (hash-table-set! (*lint* 'special-case-functions) (car op) snd-lint-deprecate))
+ deprecated-ops))
+
+
+;;; ---------------- snd-display ----------------
+;;; check snd-display using format's lint code
+
+(hash-table-set! (*lint* 'special-case-functions) 'snd-display
+ (hash-table-ref (*lint* 'special-case-functions) 'format))
+
+
+;;; ---------------- defgenerator ----------------
+;;; a lint walker for defgenerator (it defines various functions in the current environment)
+
+(let ()
+ (define (get-generator caller form env)
+ (with-let (sublet *lint* :caller caller :form form :env env)
+ (when (pair? (cdr form))
+ (let ((name ((if (pair? (cadr form)) caadr cadr) form)))
+
+ (if (and (pair? (cadr form))
+ (pair? (cdadr form)))
+ (lint-walk caller (cdadr form) env))
+
+ (let ((gen? (symbol (symbol->string name) "?"))
+ (gen-make (symbol "make-" (symbol->string name))))
+ (list (make-fvar :name gen?
+ :ftype 'define
+ :decl (dummy-func 'define `(define (,gen? x) (let? x)) '(define (_ x) #f))
+ :initial-value `(define (,gen? x) (let? x))
+ :arglist (list 'x)
+ :env env)
+ (make-fvar :name gen-make
+ :ftype 'define*
+ :decl (dummy-func 'define* `(define* (,gen-make :rest x :allow-other-keys) (apply inlet x)) '(define (_ . x) #f))
+ :initial-value `(define* (,gen-make :rest x :allow-other-keys) (apply inlet x))
+ :arglist (list :rest 'x :allow-other-keys)
+ :env env)))))))
+
+ (hash-table-set! (*lint* 'walker-functions) 'defgenerator
+ (lambda (caller form env)
+ (append (get-generator caller form env) env))))
+
+
+;;; ---------------- no side effect Snd functions ----------------
+;;; Snd functions that don't affect anything outside or mess with their arguments
+
+(let ((h (*lint* 'no-side-effect-functions)))
+ (for-each
+ (lambda (s)
+ (hash-table-set! h s #t))
+ '(all-chans all-pass-bank? all-pass? apropos array-interp ask-about-unsaved-edits ask-before-overwrite
+ asymmetric-fm? axis-color axis-info axis-label-font axis-numbers-font basic-color
+ beats-per-measure beats-per-minute bes-i0 bes-i1 bes-in bes-j0 bes-j1 bes-jn bes-k0 bes-k1 bes-kn bes-y0 bes-y1 bes-yn
+ bold-peaks-font channel-amp-envs channel-data channel-properties channel-property channel-style
+ channel-sync channel-widgets channels channels-equal? channels=? chans clipping
+ clm-default-frequency clm-table-size color->list color-cutoff color-inverted color-scale
+ color? colormap colormap-name colormap-ref colormap-size colormap? comb-bank?
+ comb? combined-data-color comment contrast-control contrast-control-amp contrast-control-bounds contrast-control?
+ contrast-enhancement convolve? count-matches current-font
+ current-time cursor cursor-color cursor-location-offset cursor-position cursor-size cursor-style
+ cursor-update-interval dac-combines-channels dac-size data-color data-location data-size db->linear
+ default-output-chans default-output-header-type default-output-sample-type default-output-srate degrees->radians delay?
+ dialog-widgets disk-kspace dot-product dot-size
+ edit-fragment edit-fragment-type-name edit-list->function edit-properties edit-property
+ edit-tree edits edot-product env? enved-base enved-clip?
+ enved-envelope enved-filter enved-filter-order enved-in-dB enved-power enved-style enved-target
+ enved-wave? enved-waveform-color envelope-interp eps-bottom-margin eps-file eps-left-margin
+ eps-size erf erfc even-multiple even-weight expand-control expand-control-bounds
+ expand-control-hop expand-control-jitter expand-control-length expand-control-ramp expand-control? feql ffeql
+ fffneq ffneq fft-log-frequency fft-log-magnitude fft-window fft-window-alpha
+ fft-window-beta fft-with-phases file->frample? file->sample? file-name file-write-date filter-control-coeffs filter-control-envelope
+ filter-control-in-dB filter-control-in-hz filter-control-order filter-control-waveform-color filter-control? filter? filtered-comb-bank?
+ filtered-comb? find-dialog find-mark find-sound fir-filter? firmant? float-vector-equal? float-vector-max float-vector-min float-vector-peak
+ float-vector-peak-and-location fneq foreground-color formant-bank? formant? frample
+ framples ftell fveql get-internal-real-time getcwd getpid granulate? graph-color graph-cursor
+ graph-style graphs-horizontal grid-density gsl-ellipj gsl-ellipk gsl-roots header-type html-dir html-program hz->radians
+ identity iir-filter? initial-beg initial-dur
+ integer->mark integer->mix integer->region integer->sound integer->transform just-sounds key-binding
+ ladspa-dir left-sample lgamma linear->db lisp-graph-style lisp-graph?
+ listener-color listener-colorized listener-font listener-prompt listener-selection listener-text-color little-endian?
+ localtime locsig-ref locsig-reverb-ref locsig-type locsig? log-freq-start main-menu main-widgets
+ mark->integer mark-color mark-home mark-hook mark-name mark-properties
+ mark-property mark-sample mark-sync mark-sync-max mark-tag-height mark-tag-width mark?
+ marks max-regions max-transform-peaks maxamp maxamp-position menu-widgets min-dB mix->integer mix-color mix-dialog-mix mix-drag-hook mix-home
+ mix-length mix-name mix-properties mix-property mix-sampler? mix-sync mix-sync-max mix-tag-height mix-tag-width mix-tag-y mix-waveform-height mix? mixes
+ move-sound? moving-average? moving-max? moving-norm? mus-alsa-buffer-size
+ mus-alsa-buffers mus-alsa-capture-device mus-alsa-device mus-alsa-playback-device mus-alsa-squelch-warning mus-array-print-length mus-bytes-per-sample
+ mus-channel mus-channels mus-chebyshev-t-sum mus-chebyshev-tu-sum mus-chebyshev-u-sum mus-clipping mus-data
+ mus-describe mus-error-type->string mus-expand-filename mus-file-buffer-size mus-file-clipping mus-file-name
+ mus-float-equal-fudge-factor mus-frequency mus-generator? mus-header-raw-defaults mus-header-type->string mus-header-type-name mus-header-writable
+ mus-hop mus-increment mus-input? mus-interp-type mus-interpolate mus-length mus-location mus-max-malloc mus-max-table-size mus-name mus-offset mus-order
+ mus-output? mus-phase mus-ramp mus-sample-type->string mus-sample-type-name mus-scaler
+ mus-sound-chans mus-sound-comment mus-sound-data-location mus-sound-datum-size mus-sound-duration mus-sound-frames
+ mus-sound-framples mus-sound-header-type mus-sound-length mus-sound-loop-info mus-sound-mark-info mus-sound-maxamp mus-sound-maxamp-exists?
+ mus-sound-path mus-sound-sample-type mus-sound-samples mus-sound-srate
+ mus-sound-type-specifier mus-sound-write-date mus-srate mus-type mus-width mus-xcoeff mus-xcoeffs
+ mus-ycoeff mus-ycoeffs mus_header_t? ncos? notch? nrxycos? nrxysin?
+ nsin? odd-multiple odd-weight one-pole-all-pass? one-pole? one-zero? oscil-bank?
+ oscil? partials->polynomial partials->wave pausing peak-env-dir peaks-font
+ phase-partials->wave phase-vocoder-amp-increments phase-vocoder-amps phase-vocoder-freqs phase-vocoder-phase-increments phase-vocoder-phases phase-vocoder?
+ phases-get-peak play-arrow-size player-home player? players playing polyshape?
+ polywave? position->x position->y position-color pulse-train? pulsed-env? radians->degrees radians->hz rand-interp?
+ rand? readin? region->integer region-chans region-framples region-graph-style region-home
+ region-maxamp region-maxamp-position region-position region-sample region-sampler? region-srate region?
+ regions reverb-control-decay reverb-control-feedback reverb-control-length reverb-control-length-bounds reverb-control-lowpass reverb-control-scale
+ reverb-control-scale-bounds reverb-control? right-sample rxyk!cos? rxyk!sin? sample sample-type
+ sampler-at-end? sampler-home sampler-position sampler? samples samples->seconds sash-color
+ sawtooth-wave? script-arg script-args search-procedure seconds->samples selected-channel selected-data-color
+ selected-graph-color selected-sound selection selection-chans selection-creates-region selection-framples selection-maxamp
+ selection-maxamp-position selection-member? selection-position selection-srate selection? short-file-name
+ sinc-width singer-filter singer-nose-filter snd->sample? snd-gcs snd-global-state snd-help snd-tempnam
+ snd-url snd-urls snd-version sound->integer sound-file-extensions sound-file?
+ sound-files-in-directory sound-loop-info sound-properties sound-property sound-widgets sound? soundfont-info
+ sounds spectro-hop spectro-x-angle spectro-x-scale spectro-y-angle spectro-y-scale spectro-z-angle
+ spectro-z-scale spectrum-end spectrum-start speed-control speed-control-bounds speed-control-style
+ speed-control-tones square-wave? srate src? ssb-am? strftime sync-max sync-style syncd-marks table-lookup? tap? temp-dir
+ text-focus-color time-graph-style time-graph-type time-graph? tiny-font tmpnam tracking-cursor-style
+ transform->integer transform-graph-style transform-graph-type transform-graph?
+ transform-normalization transform-sample transform-size transform-type transform? triangle-wave? two-pole?
+ two-zero? variable-graph? wave-train? wavelet-type
+ wavo-hop wavo-trace widget-position widget-size widget-text window-height window-width
+ window-x window-y with-background-processes with-file-monitor with-gl with-inset-graph with-interrupts
+ with-menu-icons with-mix-tags with-pointer-focus with-relative-panes with-smpte-label with-toolbar with-tooltips
+ with-tracking-cursor with-verbose-cursor x->position x-axis-label x-axis-style x-bounds x-position-slider
+ x-zoom-slider y->position y-axis-label y-bounds y-position-slider y-zoom-slider zoom-color
+ zoom-focus-style zoom-one-pixel)))
+
+
+;;; ---------------- Snd booleans ----------------
+;;; add Snd/clm type checkers to lint's table (lint assumes that these take one argument)
+
+(for-each (lambda (tchk)
+ (hash-table-set! (*lint* 'booleans) tchk #t))
+ '(all-pass? all-pass-bank? asymmetric-fm? comb? comb-bank? convolve? delay? env? file->sample? filter? filtered-comb?
+ filtered-comb-bank? fir-filter? firmant? formant-bank? formant? granulate? iir-filter? locsig? move-sound? moving-average?
+ moving-max? moving-norm? mus-generator? mus-input? mus-output? ncos? notch? nrxycos? nrxysin? nsin? one-pole? one-pole-all-pass?
+ one-zero? oscil? oscil-bank? phase-vocoder? polyshape? polywave? pulse-train? pulsed-env? rand-interp? rand? readin?
+ rxyk!cos? rxyk!sin? sample->file? sawtooth-wave? square-wave? src? ssb-am? table-lookup? tap? triangle-wave? two-pole?
+ two-zero? wave-train? file->frample? frample->file?
+
+ mark? mix? mix-sampler? region?))
+
diff --git a/snd-marks.c b/snd-marks.c
index 75e1eab..06e18bd 100644
--- a/snd-marks.c
+++ b/snd-marks.c
@@ -991,7 +991,7 @@ bool mark_define_region(chan_info *cp, int count)
reactivate_selection(si->cps[i], beg, ends[0]);
update_graph(si->cps[i]);
}
- si = free_sync_info(si);
+ free_sync_info(si);
return(true);
}
}
@@ -2333,7 +2333,6 @@ find the mark in snd's channel chn at samp (if a number) or with the given name
return(Xen_false);
}
-
static Xen g_add_mark_1(Xen samp_n, Xen snd, Xen chn_n, Xen name, Xen sync, bool check_sample, const char *caller)
{
#define H_add_mark "(" S_add_mark " samp :optional snd chn name (sync 0)): add a mark at sample samp returning the mark."
@@ -2661,7 +2660,7 @@ static char *map_mark_sync(chan_info *cp, mark *m, save_mark_info *sv)
#endif
#if HAVE_SCHEME
- fprintf(sv->fd, "(let ((%s%d (1+ (mark-sync-max))))\n", SYNC_BASE, cur_sync);
+ fprintf(sv->fd, "(let ((%s%d (+ (mark-sync-max) 1)))\n", SYNC_BASE, cur_sync);
#endif
#if HAVE_RUBY
@@ -2918,33 +2917,53 @@ void g_init_marks(void)
#define H_mark_hook S_mark_hook " (id snd chn reason): called when a mark added, deleted, or moved. \
'Reason' can be 0: add, 1: delete, 2: move, 3: delete all marks"
+#if HAVE_SCHEME
+ s7_pointer i, m, b, s, p, t, pl_im, pl_add, pl_i;
+ i = s7_make_symbol(s7, "integer?");
+ m = s7_make_symbol(s7, "mark?");
+ b = s7_make_symbol(s7, "boolean?");
+ s = s7_make_symbol(s7, "string?");
+ p = s7_make_symbol(s7, "list?");
+ t = s7_t(s7);
+ pl_im = s7_make_signature(s7, 2, i, m);
+ pl_add = s7_make_signature(s7, 6, s7_make_signature(s7, 2, m, b), i, t, t, s7_make_signature(s7, 2, s, b), i);
+ pl_i = s7_make_circular_signature(s7, 0, 1, i);
+#endif
+
init_xen_mark();
mark_drag_hook = Xen_define_hook(S_mark_drag_hook, "(make-hook 'id)", 1, H_mark_drag_hook);
mark_hook = Xen_define_hook(S_mark_hook, "(make-hook 'id 'snd 'chn 'reason)", 4, H_mark_hook);
- Xen_define_dilambda(S_mark_sample, g_mark_sample_w, H_mark_sample, S_set S_mark_sample, g_set_mark_sample_w, 1, 1, 2, 0);
- Xen_define_dilambda(S_mark_sync, g_mark_sync_w, H_mark_sync, S_set S_mark_sync, g_set_mark_sync_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mark_name, g_mark_name_w, H_mark_name, S_set S_mark_name, g_set_mark_name_w, 1, 0, 2, 0);
-
- Xen_define_safe_procedure(S_mark_sync_max, g_mark_sync_max_w, 0, 0, 0, H_mark_sync_max);
- Xen_define_safe_procedure(S_mark_home, g_mark_home_w, 1, 0, 0, H_mark_home);
- Xen_define_safe_procedure(S_marks, g_marks_w, 0, 3, 0, H_marks);
- Xen_define_safe_procedure(S_add_mark, g_add_mark_w, 0, 5, 0, H_add_mark);
- Xen_define_safe_procedure(S_add_mark "!", g_add_mark_unchecked_w, 0, 5, 0, H_add_mark_unchecked);
- Xen_define_safe_procedure(S_delete_mark, g_delete_mark_w, 1, 0, 0, H_delete_mark);
- Xen_define_safe_procedure(S_delete_marks, g_delete_marks_w, 0, 2, 0, H_delete_marks);
- Xen_define_safe_procedure(S_syncd_marks, g_syncd_marks_w, 1, 0, 0, H_syncd_marks);
- Xen_define_safe_procedure(S_find_mark, g_find_mark_w, 1, 3, 0, H_find_mark);
- Xen_define_safe_procedure(S_save_marks, g_save_marks_w, 0, 2, 0, H_save_marks);
- Xen_define_safe_procedure(S_is_mark, g_is_mark_w, 1, 0, 0, H_is_mark);
- Xen_define_safe_procedure(S_integer_to_mark, g_integer_to_mark_w, 1, 0, 0, H_integer_to_mark);
- Xen_define_safe_procedure(S_mark_to_integer, g_mark_to_integer_w, 1, 0, 0, H_mark_to_integer);
-
- Xen_define_dilambda(S_mark_tag_width, g_mark_tag_width_w, H_mark_tag_width, S_set S_mark_tag_width, g_set_mark_tag_width_w, 0, 0, 1, 0);
- Xen_define_dilambda(S_mark_tag_height, g_mark_tag_height_w, H_mark_tag_height, S_set S_mark_tag_height, g_set_mark_tag_height_w, 0, 0, 1, 0);
- Xen_define_dilambda(S_mark_properties, g_mark_properties_w, H_mark_properties, S_set S_mark_properties, g_set_mark_properties_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mark_property, g_mark_property_w, H_mark_property, S_set S_mark_property, g_set_mark_property_w, 2, 0, 3, 0);
+ Xen_define_typed_dilambda(S_mark_sample, g_mark_sample_w, H_mark_sample, S_set S_mark_sample, g_set_mark_sample_w, 1, 1, 2, 0,
+ s7_make_signature(s7, 3, i, m, i), s7_make_signature(s7, 3, i, m, i));
+ /* this is bad: the second arg to mark-sample is edit-position, but to set_mark_sample is the new sample! */
+ Xen_define_typed_dilambda(S_mark_sync, g_mark_sync_w, H_mark_sync, S_set S_mark_sync, g_set_mark_sync_w, 1, 0, 2, 0, pl_im,
+ s7_make_signature(s7, 3, i, m, s7_make_signature(s7, 2, i, b)));
+ Xen_define_typed_dilambda(S_mark_name, g_mark_name_w, H_mark_name, S_set S_mark_name, g_set_mark_name_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, s, m), s7_make_signature(s7, 3, s, m, s));
+
+ Xen_define_typed_procedure(S_mark_sync_max, g_mark_sync_max_w, 0, 0, 0, H_mark_sync_max, s7_make_signature(s7, 1, i));
+ Xen_define_typed_procedure(S_mark_home, g_mark_home_w, 1, 0, 0, H_mark_home, s7_make_signature(s7, 2, p, m));
+ Xen_define_typed_procedure(S_marks, g_marks_w, 0, 3, 0, H_marks, s7_make_circular_signature(s7, 1, 2, p, t));
+ Xen_define_typed_procedure(S_add_mark, g_add_mark_w, 0, 5, 0, H_add_mark, pl_add);
+ Xen_define_typed_procedure(S_add_mark "!", g_add_mark_unchecked_w, 0, 5, 0, H_add_mark_unchecked, pl_add);
+ Xen_define_typed_procedure(S_delete_mark, g_delete_mark_w, 1, 0, 0, H_delete_mark, s7_make_signature(s7, 2, t, m));
+ Xen_define_typed_procedure(S_delete_marks, g_delete_marks_w, 0, 2, 0, H_delete_marks, s7_make_signature(s7, 3, b, t, t));
+ Xen_define_typed_procedure(S_syncd_marks, g_syncd_marks_w, 1, 0, 0, H_syncd_marks, s7_make_signature(s7, 2, p, i));
+ Xen_define_typed_procedure(S_find_mark, g_find_mark_w, 1, 3, 0, H_find_mark,
+ s7_make_circular_signature(s7, 2, 3, s7_make_signature(s7, 2, m, b), s7_make_signature(s7, 2, i, s), t));
+ Xen_define_typed_procedure(S_save_marks, g_save_marks_w, 0, 2, 0, H_save_marks, s7_make_signature(s7, 3, s, t, s));
+ Xen_define_typed_procedure(S_is_mark, g_is_mark_w, 1, 0, 0, H_is_mark, s7_make_signature(s7, 2, b, t));
+ Xen_define_typed_procedure(S_integer_to_mark, g_integer_to_mark_w, 1, 0, 0, H_integer_to_mark, s7_make_signature(s7, 2, m, i));
+ Xen_define_typed_procedure(S_mark_to_integer, g_mark_to_integer_w, 1, 0, 0, H_mark_to_integer, s7_make_signature(s7, 2, i, m));
+
+ Xen_define_typed_dilambda(S_mark_tag_width, g_mark_tag_width_w, H_mark_tag_width, S_set S_mark_tag_width, g_set_mark_tag_width_w, 0, 0, 1, 0, pl_i, pl_i);
+ Xen_define_typed_dilambda(S_mark_tag_height, g_mark_tag_height_w, H_mark_tag_height, S_set S_mark_tag_height, g_set_mark_tag_height_w, 0, 0, 1, 0, pl_i, pl_i);
+ Xen_define_typed_dilambda(S_mark_properties, g_mark_properties_w, H_mark_properties, S_set S_mark_properties, g_set_mark_properties_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, p, m), s7_make_signature(s7, 3, p, m, p));
+ Xen_define_typed_dilambda(S_mark_property, g_mark_property_w, H_mark_property, S_set S_mark_property, g_set_mark_property_w, 2, 0, 3, 0,
+ s7_make_signature(s7, 3, t, t, m), s7_make_circular_signature(s7, 3, 4, t, t, m, t));
#define H_draw_mark_hook S_draw_mark_hook " (id): called before a mark is drawn. \
If the hook returns " PROC_TRUE ", the mark is not drawn."
diff --git a/snd-mix.c b/snd-mix.c
index 688db7e..3fe2e76 100644
--- a/snd-mix.c
+++ b/snd-mix.c
@@ -14,7 +14,7 @@ static bool mix_vct_untagged(vct *v, chan_info *cp, mus_long_t beg, const char *
sf = init_sample_read(beg, cp, READ_FORWARD);
samples_to_vct_with_reader(len, data, sf);
for (i = 0; i < len; i++) data[i] += vdata[i];
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
result = change_samples(beg, len, data, cp, origin, cp->edit_ctr, -1.0); /* cp->edit_ctr since mix-vct has no edpos arg, similarly mix */
if (result) update_graph(cp);
@@ -113,7 +113,7 @@ static bool mix_file_untagged(const char *filename, int in_chan, chan_info *cp,
close_temp_file(ofile, ofd, ohdr->type, num * mus_bytes_per_sample(ohdr->sample_type));
mus_file_close(ifd);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
free(data[in_chan]);
free(data);
free_file_info(ihdr);
@@ -223,7 +223,7 @@ int mix_complete_file(snd_info *sp, mus_long_t beg, const char *fullname, bool w
id = mix_file(beg, len, chans, cps, fullname, auto_delete, NULL, with_tag, 0);
if (si)
- si = free_sync_info(si);
+ free_sync_info(si);
else
{
if (cps)
@@ -3594,6 +3594,7 @@ Xen g_make_mix_sampler(Xen mix_id, Xen ubeg)
mf->sf->region = md->id;
return(Xen_make_object(mf_tag, mf, 0, free_mf));
}
+ free(mf);
}
return(Xen_false);
}
@@ -3992,6 +3993,18 @@ static s7_pointer acc_with_mix_tags(s7_scheme *sc, s7_pointer args) {return(g_se
void g_init_mix(void)
{
+#if HAVE_SCHEME
+ s7_pointer i, m, b, s, p, t, f, ms;
+ i = s7_make_symbol(s7, "integer?");
+ m = s7_make_symbol(s7, "mix?");
+ ms = s7_make_symbol(s7, "mix-sampler?");
+ b = s7_make_symbol(s7, "boolean?");
+ s = s7_make_symbol(s7, "string?");
+ p = s7_make_symbol(s7, "list?");
+ f = s7_make_symbol(s7, "float?");
+ t = s7_t(s7);
+#endif
+
init_xen_mix();
#if HAVE_SCHEME
@@ -4011,40 +4024,54 @@ void g_init_mix(void)
fth_set_object_apply(mf_tag, Xen_procedure_cast g_read_mix_sample, 0, 0, 0);
#endif
- Xen_define_safe_procedure(S_make_mix_sampler, g_make_mix_sampler_w, 1, 1, 0, H_make_mix_sampler);
- Xen_define_safe_procedure(S_read_mix_sample, g_read_mix_sample_w, 1, 0, 0, H_read_mix_sample);
- Xen_define_safe_procedure(S_is_mix_sampler, g_is_mix_sampler_w, 1, 0, 0, H_is_mix_sampler);
- Xen_define_procedure(S_save_mix, g_save_mix_w, 2, 0, 0, H_save_mix);
+ Xen_define_typed_procedure(S_make_mix_sampler, g_make_mix_sampler_w, 1, 1, 0, H_make_mix_sampler, s7_make_signature(s7, 3, ms, m, i));
+ Xen_define_typed_procedure(S_read_mix_sample, g_read_mix_sample_w, 1, 0, 0, H_read_mix_sample, s7_make_signature(s7, 2, f, ms));
+ Xen_define_typed_procedure(S_is_mix_sampler, g_is_mix_sampler_w, 1, 0, 0, H_is_mix_sampler, s7_make_signature(s7, 2, b, t));
+ Xen_define_procedure(S_save_mix, g_save_mix_w, 2, 0, 0, H_save_mix);
Xen_define_procedure(S_mix, g_mix_w, 1, 6, 0, H_mix);
Xen_define_procedure(S_mix_vct, g_mix_vct_w, 1, 5, 0, H_mix_vct);
- Xen_define_safe_procedure(S_mixes, g_mixes_w, 0, 2, 0, H_mixes);
- Xen_define_safe_procedure(S_mix_home, g_mix_home_w, 1, 0, 0, H_mix_home);
- Xen_define_safe_procedure(S_is_mix, g_is_mix_w, 1, 0, 0, H_is_mix);
- Xen_define_safe_procedure(S_mix_length, g_mix_length_w, 1, 0, 0, H_mix_length);
- Xen_define_safe_procedure(S_integer_to_mix, g_integer_to_mix_w, 1, 0, 0, H_integer_to_mix);
- Xen_define_safe_procedure(S_mix_to_integer, g_mix_to_integer_w, 1, 0, 0, H_mix_to_integer);
- Xen_define_safe_procedure(S_view_mixes_dialog, g_view_mixes_dialog_w, 0, 0, 0, H_view_mixes_dialog);
- Xen_define_safe_procedure(S_mix_sync_max, g_mix_sync_max_w, 0, 0, 0, H_mix_sync_max);
-
- Xen_define_dilambda(S_mix_position, g_mix_position_w, H_mix_position, S_set S_mix_position, g_set_mix_position_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mix_speed, g_mix_speed_w, H_mix_speed, S_set S_mix_speed, g_set_mix_speed_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mix_amp, g_mix_amp_w, H_mix_amp, S_set S_mix_amp, g_set_mix_amp_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mix_amp_env, g_mix_amp_env_w, H_mix_amp_env, S_set S_mix_amp_env, g_set_mix_amp_env_w, 1, 0, 2, 0);
-
- Xen_define_dilambda(S_mix_name, g_mix_name_w, H_mix_name, S_set S_mix_name, g_set_mix_name_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mix_sync, g_mix_sync_w, H_mix_sync, S_set S_mix_sync, g_set_mix_sync_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mix_properties, g_mix_properties_w, H_mix_properties, S_set S_mix_properties, g_set_mix_properties_w, 1, 0, 2, 0);
- Xen_define_dilambda(S_mix_property, g_mix_property_w, H_mix_property, S_set S_mix_property, g_set_mix_property_w, 2, 0, 3, 0);
- Xen_define_dilambda(S_mix_tag_y, g_mix_tag_y_w, H_mix_tag_y, S_set S_mix_tag_y, g_set_mix_tag_y_w, 1, 0, 2, 0);
-
- Xen_define_dilambda(S_mix_tag_width, g_mix_tag_width_w, H_mix_tag_width, S_set S_mix_tag_width, g_set_mix_tag_width_w, 0, 0, 1, 0);
- Xen_define_dilambda(S_mix_tag_height, g_mix_tag_height_w, H_mix_tag_height, S_set S_mix_tag_height, g_set_mix_tag_height_w, 0, 0, 1, 0);
-
- Xen_define_dilambda(S_mix_waveform_height, g_mix_waveform_height_w, H_mix_waveform_height, S_set S_mix_waveform_height, g_set_mix_waveform_height_w, 0, 0, 1, 0);
- Xen_define_dilambda(S_with_mix_tags, g_with_mix_tags_w, H_with_mix_tags, S_set S_with_mix_tags, g_set_with_mix_tags_w, 0, 0, 1, 0);
- Xen_define_dilambda(S_mix_dialog_mix, g_mix_dialog_mix_w, H_mix_dialog_mix, S_set S_mix_dialog_mix, g_set_mix_dialog_mix_w, 0, 0, 1, 0);
+ Xen_define_typed_procedure(S_mixes, g_mixes_w, 0, 2, 0, H_mixes, s7_make_signature(s7, 3, p, t, t));
+ Xen_define_typed_procedure(S_mix_home, g_mix_home_w, 1, 0, 0, H_mix_home, s7_make_signature(s7, 2, p, m));
+ Xen_define_typed_procedure(S_is_mix, g_is_mix_w, 1, 0, 0, H_is_mix, s7_make_signature(s7, 2, b, t));
+ Xen_define_typed_procedure(S_mix_length, g_mix_length_w, 1, 0, 0, H_mix_length, s7_make_signature(s7, 2, i, m));
+ Xen_define_typed_procedure(S_integer_to_mix, g_integer_to_mix_w, 1, 0, 0, H_integer_to_mix, s7_make_signature(s7, 2, m, i));
+ Xen_define_typed_procedure(S_mix_to_integer, g_mix_to_integer_w, 1, 0, 0, H_mix_to_integer, s7_make_signature(s7, 2, i, m));
+ Xen_define_typed_procedure(S_view_mixes_dialog, g_view_mixes_dialog_w, 0, 0, 0, H_view_mixes_dialog, s7_make_signature(s7, 1, p));
+ Xen_define_typed_procedure(S_mix_sync_max, g_mix_sync_max_w, 0, 0, 0, H_mix_sync_max, s7_make_signature(s7, 1, i));
+
+ Xen_define_typed_dilambda(S_mix_position, g_mix_position_w, H_mix_position, S_set S_mix_position, g_set_mix_position_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, i, m), s7_make_signature(s7, 3, i, m, i));
+ Xen_define_typed_dilambda(S_mix_speed, g_mix_speed_w, H_mix_speed, S_set S_mix_speed, g_set_mix_speed_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, f, m), s7_make_signature(s7, 3, f, m, f));
+ Xen_define_typed_dilambda(S_mix_amp, g_mix_amp_w, H_mix_amp, S_set S_mix_amp, g_set_mix_amp_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, f, m), s7_make_signature(s7, 3, f, m, f));
+ Xen_define_typed_dilambda(S_mix_amp_env, g_mix_amp_env_w, H_mix_amp_env, S_set S_mix_amp_env, g_set_mix_amp_env_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, p, m), s7_make_signature(s7, 3, p, m, s7_make_signature(s7, 2, p, b)));
+
+ Xen_define_typed_dilambda(S_mix_name, g_mix_name_w, H_mix_name, S_set S_mix_name, g_set_mix_name_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, s, m), s7_make_signature(s7, 3, s, m, s));
+ Xen_define_typed_dilambda(S_mix_sync, g_mix_sync_w, H_mix_sync, S_set S_mix_sync, g_set_mix_sync_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, i, m), s7_make_signature(s7, 3, i, m, s7_make_signature(s7, 2, i, b)));
+ Xen_define_typed_dilambda(S_mix_properties, g_mix_properties_w, H_mix_properties, S_set S_mix_properties, g_set_mix_properties_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, p, m), s7_make_signature(s7, 3, p, m, p));
+ Xen_define_typed_dilambda(S_mix_property, g_mix_property_w, H_mix_property, S_set S_mix_property, g_set_mix_property_w, 2, 0, 3, 0,
+ s7_make_signature(s7, 3, t, t, m), s7_make_circular_signature(s7, 3, 4, t, t, m, t));
+ Xen_define_typed_dilambda(S_mix_tag_y, g_mix_tag_y_w, H_mix_tag_y, S_set S_mix_tag_y, g_set_mix_tag_y_w, 1, 0, 2, 0,
+ s7_make_signature(s7, 2, i, m), s7_make_signature(s7, 3, i, m, i));
+
+ Xen_define_typed_dilambda(S_mix_tag_width, g_mix_tag_width_w, H_mix_tag_width, S_set S_mix_tag_width, g_set_mix_tag_width_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, i), s7_make_signature(s7, 2, i, i));
+ Xen_define_typed_dilambda(S_mix_tag_height, g_mix_tag_height_w, H_mix_tag_height, S_set S_mix_tag_height, g_set_mix_tag_height_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, i), s7_make_signature(s7, 2, i, i));
+
+ Xen_define_typed_dilambda(S_mix_waveform_height, g_mix_waveform_height_w, H_mix_waveform_height, S_set S_mix_waveform_height, g_set_mix_waveform_height_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, i), s7_make_signature(s7, 2, i, i));
+ Xen_define_typed_dilambda(S_with_mix_tags, g_with_mix_tags_w, H_with_mix_tags, S_set S_with_mix_tags, g_set_with_mix_tags_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, b), s7_make_signature(s7, 2, b, b));
+ Xen_define_typed_dilambda(S_mix_dialog_mix, g_mix_dialog_mix_w, H_mix_dialog_mix, S_set S_mix_dialog_mix, g_set_mix_dialog_mix_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, m), s7_make_signature(s7, 2, m, m));
#define H_mix_release_hook S_mix_release_hook " (id samples): called after the mouse has dragged a mix to some new position. \
'samples' = samples moved in the course of the drag. If it returns " PROC_TRUE ", the actual remix is the hook's responsibility."
diff --git a/snd-motif.scm b/snd-motif.scm
index a8e5b52..cba0613 100644
--- a/snd-motif.scm
+++ b/snd-motif.scm
@@ -78,7 +78,7 @@
(do ((i 0 (+ i 1)))
((= i len) new-str)
(let ((c (str i)))
- (set! (new-str i) (if (memq c '(#\\ #\/)) #\_ c))))))))
+ (set! (new-str i) (if (memv c '(#\\ #\/)) #\_ c))))))))
;;; -------- apply func to every widget belonging to w (and w) --------
@@ -164,17 +164,15 @@
;; (XtGetValues dialog (XmNfileSearchProc 0)) to get the default
(shell (cadr (main-widgets)))
(tags (list "one" "two" "three" "four"))
- (colors (list "black" "red" "blue" "orange"))
(pixels (let* ((dpy (XtDisplay shell))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(map
(lambda (color)
(let ((col (XColor)))
(if (= (XAllocNamedColor dpy cmap color col col) 0)
(snd-error (format #f "can't allocate ~A" color))
(.pixel col))))
- colors)))
+ '("black" "red" "blue" "orange"))))
(rendertable (XmRenderTableAddRenditions
#f
(map (lambda (tag pix)
@@ -345,10 +343,7 @@
(define add-listener-pane
(let ((documentation "(add-listener-pane name type args) adds a widget at the top of the listener"))
(lambda (name type args)
- (let* ((listener (find-child (cadr (main-widgets)) "lisp-listener"))
- ;; this is the listener text widget, hopefully
- ;; its parent is the scrolled window, its parent is the form widget filling the listener pane
- (listener-scroll (XtParent listener))
+ (let* ((listener-scroll (XtParent (find-child (cadr (main-widgets)) "lisp-listener")))
(listener-form (XtParent listener-scroll)))
;; to insert the new widget at the top of the listener pane we need to detach the
;; listener scrolled window etc -- assume here that the "args" list does not
@@ -1147,8 +1142,7 @@
;; this is the procedure to be called when the update is done
(do ((i 0 (+ i 1)))
((= i (channels updated-snd)))
- (make-mark-list updated-snd i))))))
- )
+ (make-mark-list updated-snd i)))))))
;;; -------- select-file --------
@@ -1224,9 +1218,7 @@
(XtSetValues (XtNameToWidget new-dialog "OK")
(list XmNarmColor *selection-color*))
new-dialog))))
- (if (not help)
- (XtUnmanageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON))
- (XtManageChild (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON)))
+ ((if (not help) XtUnmanageChild XtManageChild) (XmFileSelectionBoxGetChild dialog XmDIALOG_HELP_BUTTON))
(let ((patstr (XmStringCreateLocalized filter))
(titlestr (XmStringCreateLocalized title)))
(let ((dirstr (XmStringCreateLocalized dir)))
@@ -1530,10 +1522,8 @@
(documentation "(red-pixel) returns a red pixel"))
(lambda ()
(if (not pix)
- (let* ((shell (cadr (main-widgets)))
- (dpy (XtDisplay shell))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr))
+ (let* ((dpy (XtDisplay (cadr (main-widgets))))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy)))
(col (XColor)))
(if (= (XAllocNamedColor dpy cmap "red" col col) 0)
(snd-error "can't allocate red!")
@@ -1720,8 +1710,8 @@
(let ((documentation "(make-channel-drop-site snd) adds a drop site pane to the current channel"))
(lambda args
(let* ((snd (if (pair? args) (car args) (selected-sound)))
- (chn (selected-channel snd))
- (widget (add-channel-pane snd chn "drop here" xmDrawingAreaWidgetClass
+ (widget (add-channel-pane snd (selected-channel snd)
+ "drop here" xmDrawingAreaWidgetClass
(list XmNbackground (white-pixel)
XmNleftAttachment XmATTACH_FORM
XmNrightAttachment XmATTACH_FORM
@@ -1791,15 +1781,14 @@
(define show-disk-space
(let ((labelled-snds ()))
(define (kmg num)
- (cond ((<= num 0) "disk full!")
+ (cond ((<= num 0) (copy "disk full!"))
((<= num 1024) (format #f "space: ~10DK" num))
((> num 1048576) (format #f "space: ~6,3FG" (/ num (* 1024.0 1024.0))))
(else (format #f "space: ~6,3FM" (/ num 1024.0)))))
(define (show-label data id)
(if (sound? (car data))
- (let* ((space (kmg (disk-kspace (file-name (car data)))))
- (str (XmStringCreateLocalized space)))
+ (let ((str (XmStringCreateLocalized (kmg (disk-kspace (file-name (car data)))))))
(XtSetValues (cadr data) (list XmNlabelString str))
(XmStringFree str)
(XtAppAddTimeOut (caddr data) 10000 show-label data))))
@@ -1817,8 +1806,7 @@
(unite-button (widgets 6))
(sync-button (widgets 9))
(name-form (XtParent status-area)) ; "snd-name-form"
- (space (kmg (disk-kspace (file-name snd))))
- (str (XmStringCreateLocalized space)))
+ (str (XmStringCreateLocalized (kmg (disk-kspace (file-name snd))))))
(set! showing-disk-space #t)
(XtUnmanageChild status-area)
(XtVaSetValues status-area (list XmNrightAttachment XmATTACH_NONE))
@@ -1850,9 +1838,9 @@
(let ((documentation "(add-amp-controls) adds amplitude sliders to the control panel for each channel in multi-channel sounds"))
(lambda ()
- (define (label-name chan) (if (= chan 0) "amp-label" (format #f "amp-label-~D" chan)))
- (define (number-name chan) (if (= chan 0) "amp-number" (format #f "amp-number-~D" chan)))
- (define (scroller-name chan) (if (= chan 0) "amp" (format #f "amp-~D" chan)))
+ (define (label-name chan) (if (= chan 0) (copy "amp-label") (format #f "amp-label-~D" chan)))
+ (define (number-name chan) (if (= chan 0) (copy "amp-number") (format #f "amp-number-~D" chan)))
+ (define (scroller-name chan) (if (= chan 0) (copy "amp") (format #f "amp-~D" chan)))
(define (amp-callback w c info)
;; c is (list number-widget snd chan)
@@ -1865,16 +1853,13 @@
(let* ((snd (cadr c))
(amp (scroll->amp snd (.value info)))
(ampstr (XmStringCreateLocalized (format #f "~,3F " amp)))
- (top-chn (- (channels snd) 1))
- (chn (- top-chn (caddr c)))
+ (chn (- (channels snd) 1 (caddr c)))
(ctrl (and (.event info) (not (= (logand (.state (.event info)) ControlMask) 0)))))
(XtSetValues (car c) (list XmNlabelString ampstr))
(XmStringFree ampstr)
(if ctrl
- (let* ((wids (sound-widgets snd))
- (ctrls (wids 2))
- (snd-amp (find-child ctrls "snd-amp"))
- (chns (channels snd)))
+ (let ((snd-amp (find-child ((sound-widgets snd) 2) "snd-amp"))
+ (chns (channels snd)))
(do ((i 0 (+ i 1)))
((= i chns))
(let* ((ampscr (find-child snd-amp (scroller-name i)))
@@ -1945,8 +1930,7 @@
(XmStringFree s2)
label))
- (let* ((wids (sound-widgets snd))
- (ctrls (wids 2))
+ (let* ((ctrls ((sound-widgets snd) 2))
(snd-amp (find-child ctrls "snd-amp"))
(chns (channels snd)))
@@ -2010,10 +1994,8 @@
(define (amp-controls-clear snd)
(if (> (channels snd) 1)
- (let* ((wids (sound-widgets snd))
- (ctrls (wids 2))
- (snd-amp (find-child ctrls "snd-amp"))
- (top (- (channels snd) 1)))
+ (let ((snd-amp (find-child ((sound-widgets snd) 2) "snd-amp"))
+ (top (- (channels snd) 1)))
(do ((i 1 (+ i 1)))
((= i (channels snd)))
(let ((ampn (find-child snd-amp (number-name i)))
@@ -2139,9 +2121,7 @@
(XtAddEventHandler rename-text LeaveWindowMask #f
(lambda (w context ev flag)
(XtSetValues w (list XmNbackground *basic-color*)))))))
- (if (not (XtIsManaged rename-dialog))
- (XtManageChild rename-dialog)
- (raise-dialog rename-dialog)))
+ ((if (not (XtIsManaged rename-dialog)) XtManageChild raise-dialog) rename-dialog))
8)))))
@@ -2174,8 +2154,7 @@
(lambda (color-name)
(let* ((col (XColor))
(dpy (XtDisplay (cadr (main-widgets))))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(if (= (XAllocNamedColor dpy cmap color-name col col) 0)
(snd-error (format #f "can't allocate ~A" color-name))
(.pixel col)))))
@@ -2233,46 +2212,46 @@
(if (and tooltip-shell (XtIsManaged tooltip-shell))
(XtUnmanageChild tooltip-shell)))
- (define start-tooltip
- (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget)
- (timeout 500)) ; millisecs after mouse enters widget to tip display
- (lambda (ev)
- (if (and *with-tooltips*
- (not tool-proc))
- (set! tool-proc (XtAppAddTimeOut
- (car (main-widgets))
- timeout
- (lambda (data id)
- (if tooltip-shell
- (change-label tooltip-label tip)
- (begin
- (set! tooltip-shell (XtCreatePopupShell
- tip
- overrideShellWidgetClass
- (cadr (main-widgets))
- (list XmNallowShellResize #t)))
- (set! tooltip-label
- (XtCreateManagedWidget
- tip
- xmLabelWidgetClass
- tooltip-shell
- (list XmNrecomputeSize #t
- XmNbackground *highlight-color*)))))
- (let ((loc (XtTranslateCoords widget (.x ev) (.y ev))))
- (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc))))
- (XtManageChild tooltip-shell)
- (set! quit-proc (XtAppAddTimeOut
- (car (main-widgets))
- quittime
- (lambda (data id)
- (XtUnmanageChild tooltip-shell)
- (set! quit-proc #f)))))))))))
-
- (XtAddEventHandler widget EnterWindowMask #f
- (lambda (w c ev flag)
- (if (> (- (cadr (.time ev)) last-time) 50)
- (start-tooltip ev))
- (set! last-time (cadr (.time ev)))))
+ (let ((start-tooltip
+ (let ((quittime 3000) ; millisecs to show tip (if pointer not already moved out of widget)
+ (timeout 500)) ; millisecs after mouse enters widget to tip display
+ (lambda (ev)
+ (if (and *with-tooltips*
+ (not tool-proc))
+ (set! tool-proc (XtAppAddTimeOut
+ (car (main-widgets))
+ timeout
+ (lambda (data id)
+ (if tooltip-shell
+ (change-label tooltip-label tip)
+ (begin
+ (set! tooltip-shell (XtCreatePopupShell
+ tip
+ overrideShellWidgetClass
+ (cadr (main-widgets))
+ (list XmNallowShellResize #t)))
+ (set! tooltip-label
+ (XtCreateManagedWidget
+ tip
+ xmLabelWidgetClass
+ tooltip-shell
+ (list XmNrecomputeSize #t
+ XmNbackground *highlight-color*)))))
+ (let ((loc (XtTranslateCoords widget (.x ev) (.y ev))))
+ (XtVaSetValues tooltip-shell (list XmNx (car loc) XmNy (cadr loc))))
+ (XtManageChild tooltip-shell)
+ (set! quit-proc (XtAppAddTimeOut
+ (car (main-widgets))
+ quittime
+ (lambda (data id)
+ (XtUnmanageChild tooltip-shell)
+ (set! quit-proc #f))))))))))))
+
+ (XtAddEventHandler widget EnterWindowMask #f
+ (lambda (w c ev flag)
+ (if (> (- (cadr (.time ev)) last-time) 50)
+ (start-tooltip ev))
+ (set! last-time (cadr (.time ev))))))
(XtAddEventHandler widget LeaveWindowMask #f
(lambda (w c ev flag)
(set! last-time (cadr (.time ev)))
@@ -2328,83 +2307,83 @@
(listener-text ((main-widgets) 4))
(snd-app (car (main-widgets))))
(lambda ()
-
- (define start-dialog
- (let ((shell (cadr (main-widgets)))
- (dialog #f)
- (find-new #t)
- (find-text #f))
- (lambda ()
- (unless dialog
- (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
- (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
- (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG)))
- (set! dialog (XmCreateMessageDialog shell
- "Find"
- (list XmNcancelLabelString xdismiss
- XmNokLabelString xfind
- XmNhelpLabelString xhelp
- XmNautoUnmanage #f
- XmNresizePolicy XmRESIZE_GROW
- XmNnoResize #f
- XmNtransient #f
- XmNbackground *basic-color*)))
- (for-each
- (lambda (button color)
- (XtVaSetValues (XmMessageBoxGetChild dialog button)
- (list XmNarmColor *selection-color*
- XmNbackground color)))
- (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
- (list *highlight-color* *highlight-color* *highlight-color*))
- (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog)))
- (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet")))
- (XtAddCallback dialog XmNokCallback (lambda (w context info)
- (let* ((search-str (XmTextFieldGetString find-text))
- (len (length search-str))
- (pos (XmTextFindString listener-text
- (+ (XmTextGetCursorPosition listener-text)
- (if find-new 0 (if find-forward 1 -1)))
- search-str
- (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
- (if (not pos)
- (set! pos (XmTextFindString listener-text
- (if find-forward 0 (XmTextGetLastPosition listener-text))
- search-str
- (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
- (if (number? pos)
- (begin
- (XmTextSetInsertionPosition listener-text pos)
- (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly
- (XtAppAddTimeOut snd-app 200
- (lambda (context id)
- (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL)))))
- (set! find-new #f))))
- (XmStringFree xhelp)
- (XmStringFree xdismiss)
- (XmStringFree xfind)
- (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog
- (list XmNleftAttachment XmATTACH_FORM
- XmNrightAttachment XmATTACH_FORM
- XmNtopAttachment XmATTACH_FORM
- XmNbottomAttachment XmATTACH_WIDGET
- XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR)
- XmNbackground *basic-color*)))
- (XtAddCallback find-text XmNfocusCallback
- (lambda (w c i)
- (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell)))))))
- (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*))))
- (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t)))))
- (XtManageChild dialog))))
- (XtAppAddActions snd-app
- (list (list "search-forward"
- (lambda args
- (set! find-forward #t)
- (start-dialog)))
- (list "search-backward"
- (lambda args
- (set! find-forward #f)
- (start-dialog)))))
+ (let ((start-dialog
+ (let ((shell (cadr (main-widgets)))
+ (dialog #f)
+ (find-new #t)
+ (find-text #f))
+ (lambda ()
+ (unless dialog
+ (let ((xdismiss (XmStringCreate "Go Away" XmFONTLIST_DEFAULT_TAG))
+ (xhelp (XmStringCreate "Help" XmFONTLIST_DEFAULT_TAG))
+ (xfind (XmStringCreate "Find" XmFONTLIST_DEFAULT_TAG)))
+ (set! dialog (XmCreateMessageDialog shell
+ "Find"
+ (list XmNcancelLabelString xdismiss
+ XmNokLabelString xfind
+ XmNhelpLabelString xhelp
+ XmNautoUnmanage #f
+ XmNresizePolicy XmRESIZE_GROW
+ XmNnoResize #f
+ XmNtransient #f
+ XmNbackground *basic-color*)))
+ (for-each
+ (lambda (button color)
+ (XtVaSetValues (XmMessageBoxGetChild dialog button)
+ (list XmNarmColor *selection-color*
+ XmNbackground color)))
+ (list XmDIALOG_HELP_BUTTON XmDIALOG_CANCEL_BUTTON XmDIALOG_OK_BUTTON)
+ (list *highlight-color* *highlight-color* *highlight-color*))
+ (XtAddCallback dialog XmNcancelCallback (lambda (w context info) (XtUnmanageChild dialog)))
+ (XtAddCallback dialog XmNhelpCallback (lambda (w context info) (help-dialog "Find" "no help yet")))
+ (XtAddCallback dialog XmNokCallback (lambda (w context info)
+ (let* ((search-str (XmTextFieldGetString find-text))
+ (len (length search-str))
+ (pos (XmTextFindString listener-text
+ (+ (XmTextGetCursorPosition listener-text)
+ (if find-new 0 (if find-forward 1 -1)))
+ search-str
+ (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
+ (if (not pos)
+ (set! pos (XmTextFindString listener-text
+ (if find-forward 0 (XmTextGetLastPosition listener-text))
+ search-str
+ (if find-forward XmTEXT_FORWARD XmTEXT_BACKWARD))))
+ (if (number? pos)
+ (begin
+ (XmTextSetInsertionPosition listener-text pos)
+ (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_SELECTED) ; flash the string briefly
+ (XtAppAddTimeOut snd-app 200
+ (lambda (context id)
+ (XmTextSetHighlight listener-text pos (+ pos len) XmHIGHLIGHT_NORMAL)))))
+ (set! find-new #f))))
+ (XmStringFree xhelp)
+ (XmStringFree xdismiss)
+ (XmStringFree xfind)
+ (set! find-text (XtCreateManagedWidget "text" xmTextFieldWidgetClass dialog
+ (list XmNleftAttachment XmATTACH_FORM
+ XmNrightAttachment XmATTACH_FORM
+ XmNtopAttachment XmATTACH_FORM
+ XmNbottomAttachment XmATTACH_WIDGET
+ XmNbottomWidget (XmMessageBoxGetChild dialog XmDIALOG_SEPARATOR)
+ XmNbackground *basic-color*)))
+ (XtAddCallback find-text XmNfocusCallback
+ (lambda (w c i)
+ (XtVaSetValues w (list XmNbackground (WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay shell)))))))
+ (XtAddCallback find-text XmNlosingFocusCallback (lambda (w c i) (XtSetValues w (list XmNbackground *basic-color*))))
+ (XtAddCallback find-text XmNvalueChangedCallback (lambda (w c i) (set! find-new #t)))))
+ (XtManageChild dialog)))))
+
+ (XtAppAddActions snd-app
+ (list (list "search-forward"
+ (lambda args
+ (set! find-forward #t)
+ (start-dialog)))
+ (list "search-backward"
+ (lambda args
+ (set! find-forward #f)
+ (start-dialog))))))
(XtOverrideTranslations listener-text
(XtParseTranslationTable "Ctrl <Key>s: search-forward()
Ctrl <Key>r: search-backward()")))))
diff --git a/snd-nogui.c b/snd-nogui.c
index dee91d9..152dfa0 100644
--- a/snd-nogui.c
+++ b/snd-nogui.c
@@ -704,7 +704,8 @@ void snd_doit(int argc, char **argv)
if ((ss->sounds) && (ss->sounds[0]) && ((ss->sounds[0])->inuse == SOUND_NORMAL))
select_channel(ss->sounds[0], 0);
-#if HAVE_SCHEME
+#if HAVE_SCHEME && (!defined(__sun))
+
if (!nostdin)
{
s7_load(s7, "repl.scm");
diff --git a/snd-prefs.c b/snd-prefs.c
index 309d391..f892f61 100644
--- a/snd-prefs.c
+++ b/snd-prefs.c
@@ -4054,7 +4054,7 @@ static char *make_show_all(char *key, bool ctrl, bool meta, bool cx)
#if HAVE_SCHEME
return(mus_format("(bind-key %s %d (lambda () \
(let ((old-sync (sync))) \
- (set! (sync) (1+ (sync-max))) \
+ (set! (sync) (+ (sync-max) 1)) \
(set! (x-bounds) (list 0.0 (/ (framples) (srate)))) \
(set! (sync) old-sync))) %s \"show entire sound\" \"show-all\")\n",
possibly_quote(key),
@@ -4125,7 +4125,7 @@ static char *make_select_all(char *key, bool ctrl, bool meta, bool cx)
#if HAVE_SCHEME
return(mus_format("(bind-key %s %d (lambda () \
(let ((old-sync (sync))) \
- (set! (sync) (1+ (sync-max))) \
+ (set! (sync) (+ (sync-max) 1)) \
(select-all) \
(set! (sync) old-sync))) %s \"select entire sound\" \"select-all\")\n",
possibly_quote(key),
diff --git a/snd-print.c b/snd-print.c
index 530968e..dcc3f70 100644
--- a/snd-print.c
+++ b/snd-print.c
@@ -549,7 +549,7 @@ static char *snd_print_or_error(const char *output)
end_ps_graph();
}
else errstr = mus_format("print %s failed: %s", output, snd_io_strerror());
- si = free_sync_info(si);
+ free_sync_info(si);
if (offsets) free(offsets);
return(errstr);
}
diff --git a/snd-region.c b/snd-region.c
index 5739269..0b321d3 100644
--- a/snd-region.c
+++ b/snd-region.c
@@ -677,7 +677,7 @@ static int paste_region_1(int n, chan_info *cp, bool add, mus_long_t beg, io_err
io_err = copy_file(r->filename, tempfile);
if (io_err != IO_NO_ERROR)
{
- if (si) si = free_sync_info(si);
+ if (si) free_sync_info(si);
(*err) = io_err;
return(INVALID_REGION);
}
@@ -708,7 +708,7 @@ static int paste_region_1(int n, chan_info *cp, bool add, mus_long_t beg, io_err
free(origin);
if ((r->use_temp_file == REGION_FILE) && (tempfile)) free(tempfile);
}
- if (si) si = free_sync_info(si);
+ if (si) free_sync_info(si);
return(id);
}
@@ -1006,7 +1006,7 @@ static void deferred_region_to_temp_file(region *r)
free(data);
data = NULL;
}
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
}
r->dr = free_deferred_region(r->dr);
}
@@ -1328,7 +1328,6 @@ io_error_t save_region(int rg, const char *name, mus_sample_t samp_type, mus_hea
if (((framples * chans * mus_sound_datum_size(r->filename)) >> 10) > disk_kspace(name))
snd_warning("not enough space to save region? -- need %lld bytes",
framples * chans * mus_sound_datum_size(r->filename));
- err = 0;
for (ioff = 0; ioff < framples; ioff += FILE_BUFFER_SIZE)
{
@@ -1736,10 +1735,10 @@ static Xen region_get(region_field_t field, Xen n, const char *caller)
switch (field)
{
- case REGION_SRATE: return(C_int_to_Xen_integer(region_srate(rg))); break;
- case REGION_CHANS: return(C_int_to_Xen_integer(region_chans(rg))); break;
- case REGION_MAXAMP: return(C_double_to_Xen_real(region_maxamp(rg))); break;
- case REGION_MAXAMP_POSITION: return(C_llong_to_Xen_llong(region_maxamp_position(rg))); break;
+ case REGION_SRATE: return(C_int_to_Xen_integer(region_srate(rg))); break;
+ case REGION_CHANS: return(C_int_to_Xen_integer(region_chans(rg))); break;
+ case REGION_MAXAMP: return(C_double_to_Xen_real(region_maxamp(rg))); break;
+ case REGION_MAXAMP_POSITION: return(C_llong_to_Xen_llong(region_maxamp_position(rg))); break;
case REGION_FORGET: delete_region_and_update_browser(region_id_to_list_position(rg)); return(n); break;
case REGION_HOME:
{
@@ -1904,7 +1903,7 @@ selection is used."
id = define_region(si, ends);
if (selection_creates_region(ss))
reactivate_selection(si->cps[0], si->begs[0], ends[0]);
- si = free_sync_info(si);
+ free_sync_info(si);
free(ends);
}
}
@@ -2178,35 +2177,48 @@ static s7_pointer acc_max_regions(s7_scheme *sc, s7_pointer args) {return(g_set_
void g_init_regions(void)
{
- init_xen_region();
+#if HAVE_SCHEME
+ s7_pointer i, b, p, t, f, fv, rg;
+ i = s7_make_symbol(s7, "integer?");
+ rg = s7_make_symbol(s7, "region?");
+ b = s7_make_symbol(s7, "boolean?");
+ p = s7_make_symbol(s7, "list?");
+ f = s7_make_symbol(s7, "float?");
+ fv = s7_make_symbol(s7, "float-vector?");
+ t = s7_t(s7);
+#endif
+ init_xen_region();
init_region_keywords();
Xen_define_procedure(S_restore_region, g_restore_region_w, 0, 0, 1, "internal func used in save-state, restores a region");
Xen_define_procedure(S_insert_region, g_insert_region_w, 2, 2, 0, H_insert_region);
- Xen_define_safe_procedure(S_regions, g_regions_w, 0, 0, 0, H_regions);
- Xen_define_safe_procedure(S_region_framples, g_region_framples_w, 1, 1, 0, H_region_framples);
- Xen_define_safe_procedure(S_region_position, g_region_position_w, 1, 1, 0, H_region_position);
- Xen_define_safe_procedure(S_region_srate, g_region_srate_w, 1, 0, 0, H_region_srate);
- Xen_define_safe_procedure(S_region_chans, g_region_chans_w, 1, 0, 0, H_region_chans);
- Xen_define_safe_procedure(S_region_home, g_region_home_w, 1, 0, 0, H_region_home);
- Xen_define_safe_procedure(S_region_maxamp, g_region_maxamp_w, 1, 0, 0, H_region_maxamp);
- Xen_define_safe_procedure(S_region_maxamp_position, g_region_maxamp_position_w, 1, 0, 0, H_region_maxamp_position);
Xen_define_procedure(S_save_region, g_save_region_w, 2, 7, 0, H_save_region);
Xen_define_procedure(S_forget_region, g_forget_region_w, 1, 0, 0, H_forget_region);
Xen_define_procedure(S_make_region, g_make_region_w, 0, 4, 0, H_make_region);
Xen_define_procedure(S_mix_region, g_mix_region_w, 1, 4, 0, H_mix_region);
- Xen_define_safe_procedure(S_region_sample, g_region_sample_w, 2, 1, 0, H_region_sample);
- Xen_define_safe_procedure(S_region_to_vct, g_region_to_vct_w, 1, 4, 0, H_region_to_vct);
- Xen_define_safe_procedure(S_is_region, g_is_region_w, 1, 0, 0, H_is_region);
-
- Xen_define_safe_procedure(S_integer_to_region, g_integer_to_region_w, 1, 0, 0, H_integer_to_region);
- Xen_define_safe_procedure(S_region_to_integer, g_region_to_integer_w, 1, 0, 0, H_region_to_integer);
-
- Xen_define_dilambda(S_max_regions, g_max_regions_w, H_max_regions, S_set S_max_regions, g_set_max_regions_w, 0, 0, 1, 0);
- Xen_define_dilambda(S_region_graph_style, g_region_graph_style_w, H_region_graph_style,
- S_set S_region_graph_style, g_set_region_graph_style_w, 0, 0, 1, 0);
+ Xen_define_typed_procedure(S_regions, g_regions_w, 0, 0, 0, H_regions, s7_make_signature(s7, 1, p));
+ Xen_define_typed_procedure(S_region_framples, g_region_framples_w, 1, 1, 0, H_region_framples, s7_make_signature(s7, 3, i, rg, i));
+ Xen_define_typed_procedure(S_region_position, g_region_position_w, 1, 1, 0, H_region_position, s7_make_signature(s7, 3, i, rg, i));
+ Xen_define_typed_procedure(S_region_srate, g_region_srate_w, 1, 0, 0, H_region_srate, s7_make_signature(s7, 2, i, rg));
+ Xen_define_typed_procedure(S_region_chans, g_region_chans_w, 1, 0, 0, H_region_chans, s7_make_signature(s7, 2, i, rg));
+ Xen_define_typed_procedure(S_region_home, g_region_home_w, 1, 0, 0, H_region_home, s7_make_signature(s7, 2, p, rg));
+ Xen_define_typed_procedure(S_region_maxamp, g_region_maxamp_w, 1, 0, 0, H_region_maxamp, s7_make_signature(s7, 2, f, rg));
+ Xen_define_typed_procedure(S_region_maxamp_position, g_region_maxamp_position_w, 1, 0, 0, H_region_maxamp_position, s7_make_signature(s7, 2, i, rg));
+ Xen_define_typed_procedure(S_region_sample, g_region_sample_w, 2, 1, 0, H_region_sample, s7_make_signature(s7, 4, f, rg, i, i));
+ Xen_define_typed_procedure(S_region_to_vct, g_region_to_vct_w, 1, 4, 0, H_region_to_vct, s7_make_signature(s7, 6, fv, rg, i, i, i, fv));
+ Xen_define_typed_procedure(S_is_region, g_is_region_w, 1, 0, 0, H_is_region, s7_make_signature(s7, 2, b, t));
+
+ Xen_define_typed_procedure(S_integer_to_region, g_integer_to_region_w, 1, 0, 0, H_integer_to_region, s7_make_signature(s7, 2, rg, i));
+ Xen_define_typed_procedure(S_region_to_integer, g_region_to_integer_w, 1, 0, 0, H_region_to_integer, s7_make_signature(s7, 2, i, rg));
+
+ Xen_define_typed_dilambda(S_max_regions, g_max_regions_w, H_max_regions, S_set S_max_regions, g_set_max_regions_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, i), s7_make_signature(s7, 2, i, i));
+
+ Xen_define_typed_dilambda(S_region_graph_style, g_region_graph_style_w, H_region_graph_style,
+ S_set S_region_graph_style, g_set_region_graph_style_w, 0, 0, 1, 0,
+ s7_make_signature(s7, 1, i), s7_make_signature(s7, 2, i, i));
#if HAVE_SCHEME
s7_symbol_set_access(s7, ss->max_regions_symbol, s7_make_function(s7, "[acc-" S_max_regions "]", acc_max_regions, 2, 0, false, "accessor"));
diff --git a/snd-select.c b/snd-select.c
index 0baa2d5..0bd9564 100644
--- a/snd-select.c
+++ b/snd-select.c
@@ -708,7 +708,7 @@ int make_region_from_selection(void)
}
if (happy) id = define_region(si, ends);
- si = free_sync_info(si);
+ free_sync_info(si);
if (ends) free(ends);
return(id);
}
@@ -730,7 +730,7 @@ int select_all(chan_info *cp)
update_graph(si->cps[i]);
}
}
- si = free_sync_info(si);
+ free_sync_info(si);
if ((selection_is_active()) && (selection_creates_region(ss)))
return(make_region_from_selection());
}
@@ -1106,7 +1106,7 @@ io_error_t save_selection(const char *ofile, int srate, mus_sample_t samp_type,
io_err = snd_write_header(ofile, head_type, srate, chans, chans * dur, samp_type, comment, NULL);
if (io_err != IO_NO_ERROR)
{
- si = free_sync_info(si);
+ free_sync_info(si);
return(io_err);
}
@@ -1127,7 +1127,7 @@ io_error_t save_selection(const char *ofile, int srate, mus_sample_t samp_type,
if (no_space != DISK_SPACE_OK)
{
snd_close(ofd, ofile);
- si = free_sync_info(si);
+ free_sync_info(si);
return(IO_DISK_FULL);
}
@@ -1156,7 +1156,7 @@ io_error_t save_selection(const char *ofile, int srate, mus_sample_t samp_type,
if (fdi == -1)
{
snd_close(ofd, ofile);
- si = free_sync_info(si);
+ free_sync_info(si);
return(IO_CANT_READ_SELECTION_FILE);
}
/* snd_error("can't read selection's original sound? %s: %s", sp->filename, snd_io_strerror()); */
@@ -1184,7 +1184,7 @@ io_error_t save_selection(const char *ofile, int srate, mus_sample_t samp_type,
snd_close(fdi, sp->filename);
}
snd_close(ofd, ofile);
- si = free_sync_info(si);
+ free_sync_info(si);
#if USE_MOTIF
if (!(ss->file_monitor_ok))
alert_new_file();
@@ -1276,7 +1276,7 @@ io_error_t save_selection(const char *ofile, int srate, mus_sample_t samp_type,
}
free(sfs);
free(data);
- si = free_sync_info(si);
+ free_sync_info(si);
free(ends);
if (mus_file_close(ofd) != 0)
@@ -1500,7 +1500,7 @@ static Xen g_set_selection_position(Xen pos, Xen snd, Xen chn)
int i;
for (i = 0; i < si->chans; i++)
cp_set_selection_beg(si->cps[i], beg);
- si = free_sync_info(si);
+ free_sync_info(si);
}
}
else
@@ -1560,7 +1560,7 @@ static Xen g_set_selection_framples(Xen samps, Xen snd, Xen chn)
int i;
for (i = 0; i < si->chans; i++)
cp_set_selection_len(si->cps[i], len);
- si = free_sync_info(si);
+ free_sync_info(si);
}
}
else
@@ -1873,25 +1873,38 @@ Xen_wrap_3_optional_args(g_set_selection_member_w, g_set_selection_member)
void g_init_selection(void)
{
+#if HAVE_SCHEME
+ s7_pointer i, b, t, f, sel;
+ i = s7_make_symbol(s7, "integer?");
+ sel = s7_make_symbol(s7, "selection?");
+ b = s7_make_symbol(s7, "boolean?");
+ f = s7_make_symbol(s7, "float?");
+ t = s7_t(s7);
+#endif
+
init_selection_keywords();
init_xen_selection();
- Xen_define_dilambda(S_selection_position, g_selection_position_w, H_selection_position, S_set S_selection_position, g_set_selection_position_w, 0, 2, 1, 2);
- Xen_define_dilambda(S_selection_framples, g_selection_framples_w, H_selection_framples, S_set S_selection_framples, g_set_selection_framples_w, 0, 2, 1, 2);
- Xen_define_dilambda(S_selection_member, g_selection_member_w, H_selection_member, S_set S_selection_member, g_set_selection_member_w, 0, 2, 1, 2);
+ Xen_define_typed_dilambda(S_selection_position, g_selection_position_w, H_selection_position, S_set S_selection_position, g_set_selection_position_w, 0, 2, 1, 2,
+ s7_make_signature(s7, 3, i, t, t), s7_make_signature(s7, 4, i, t, t, i));
+ Xen_define_typed_dilambda(S_selection_framples, g_selection_framples_w, H_selection_framples, S_set S_selection_framples, g_set_selection_framples_w, 0, 2, 1, 2,
+ s7_make_signature(s7, 3, i, t, t), s7_make_signature(s7, 4, i, t, t, i));
+ Xen_define_typed_dilambda(S_selection_member, g_selection_member_w, H_selection_member, S_set S_selection_member, g_set_selection_member_w, 0, 2, 1, 2,
+ s7_make_signature(s7, 3, b, t, t), s7_make_signature(s7, 4, b, t, t, b));
+
+ Xen_define_typed_procedure(S_selection, g_selection_w, 0, 0, 0, H_selection, s7_make_signature(s7, 1, s7_make_signature(s7, 2, sel, b)));
+ Xen_define_typed_procedure(S_is_selection, g_is_selection_w, 0, 1, 0, H_is_selection, s7_make_signature(s7, 2, b, t));
+ Xen_define_typed_procedure(S_selection_chans, g_selection_chans_w, 0, 0, 0, H_selection_chans, s7_make_signature(s7, 1, i));
+ Xen_define_typed_procedure(S_selection_srate, g_selection_srate_w, 0, 0, 0, H_selection_srate, s7_make_signature(s7, 1, i));
+ Xen_define_typed_procedure(S_selection_maxamp, g_selection_maxamp_w, 0, 2, 0, H_selection_maxamp, s7_make_signature(s7, 3, f, t, t));
+ Xen_define_typed_procedure(S_selection_maxamp_position, g_selection_maxamp_position_w, 0, 2, 0, H_selection_maxamp_position, s7_make_signature(s7, 3, i, t, t));
+ Xen_define_typed_procedure(S_select_all, g_select_all_w, 0, 2, 0, H_select_all, s7_make_signature(s7, 3, b, t, t));
+ Xen_define_typed_procedure(S_unselect_all, g_unselect_all_w, 0, 0, 0, H_unselect_all, s7_make_signature(s7, 1, b));
- Xen_define_safe_procedure(S_selection, g_selection_w, 0, 0, 0, H_selection);
- Xen_define_safe_procedure(S_is_selection, g_is_selection_w, 0, 1, 0, H_is_selection);
- Xen_define_safe_procedure(S_selection_chans, g_selection_chans_w, 0, 0, 0, H_selection_chans);
- Xen_define_safe_procedure(S_selection_srate, g_selection_srate_w, 0, 0, 0, H_selection_srate);
- Xen_define_safe_procedure(S_selection_maxamp, g_selection_maxamp_w, 0, 2, 0, H_selection_maxamp);
- Xen_define_safe_procedure(S_selection_maxamp_position, g_selection_maxamp_position_w, 0, 2, 0, H_selection_maxamp_position);
Xen_define_procedure(S_delete_selection, g_delete_selection_w, 0, 0, 0, H_delete_selection);
Xen_define_procedure(S_insert_selection, g_insert_selection_w, 0, 3, 0, H_insert_selection);
Xen_define_procedure(S_mix_selection, g_mix_selection_w, 0, 4, 0, H_mix_selection);
Xen_define_procedure(S_selection_to_mix, g_selection_to_mix_w, 0, 0, 0, H_selection_to_mix);
- Xen_define_procedure(S_select_all, g_select_all_w, 0, 2, 0, H_select_all);
Xen_define_procedure(S_save_selection, g_save_selection_w, 0, 0, 1, H_save_selection);
Xen_define_procedure(S_show_selection, g_show_selection_w, 0, 0, 0, H_show_selection);
- Xen_define_procedure(S_unselect_all, g_unselect_all_w, 0, 0, 0, H_unselect_all);
}
diff --git a/snd-sig.c b/snd-sig.c
index ed7ed1d..5af3964 100644
--- a/snd-sig.c
+++ b/snd-sig.c
@@ -862,7 +862,7 @@ static char *reverse_channel(chan_info *cp, snd_fd *sf, mus_long_t beg, mus_long
if (err != MUS_NO_ERROR) break;
}
close_temp_file(ofile, ofd, hdr->type, dur * datumb);
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
file_change_samples(beg, dur, ofile, cp, 0, DELETE_ME, origin, edpos);
if (ofile)
{
@@ -1302,12 +1302,12 @@ static char *src_channel_with_error(chan_info *cp, snd_fd *sf, mus_long_t beg, m
}
if (reporting) finish_progress_report(cp);
- sr = free_src(sr);
+ free_src(sr);
if ((!(ss->stopped_explicitly)) && (j > 0))
mus_file_write(ofd, 0, j - 1, 1, data);
close_temp_file(ofile, ofd, hdr->type, k * datumb);
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
if (!(ss->stopped_explicitly))
{
@@ -1763,13 +1763,13 @@ static char *clm_channel(chan_info *cp, mus_any *gen, mus_long_t beg, mus_long_t
dur += overlap;
}
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (temp_file)
{
if (j > 0) mus_file_write(ofd, 0, j - 1, 1, data);
close_temp_file(ofile, ofd, hdr->type, dur * datumb);
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
file_change_samples(beg, dur, ofile, cp, 0, DELETE_ME, origin, edpos);
if (ofile)
{
@@ -1957,7 +1957,7 @@ static char *convolution_filter(chan_info *cp, int order, env *e, snd_fd *sf, mu
}
}
if (ofile) {free(ofile); ofile = NULL;}
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
if ((fltdat) && (!precalculated_coeffs)) free(fltdat);
update_graph(cp);
return(NULL);
@@ -2156,7 +2156,7 @@ static char *direct_filter(chan_info *cp, int order, env *e, snd_fd *sf, mus_lon
{
if (j > 0) mus_file_write(ofd, 0, j - 1, 1, data);
close_temp_file(ofile, ofd, hdr->type, dur * datumb);
- hdr = free_file_info(hdr);
+ free_file_info(hdr);
file_change_samples(beg, dur, ofile, cp, 0, DELETE_ME, new_origin, sf->edit_ctr);
if (ofile) {free(ofile); ofile = NULL;}
}
@@ -2889,7 +2889,7 @@ void cursor_delete(chan_info *cp, mus_long_t count)
update_graph(si->cps[i]);
}
}
- si = free_sync_info(si);
+ free_sync_info(si);
}
else
{
@@ -2929,7 +2929,7 @@ void cursor_insert(chan_info *cp, mus_long_t beg, mus_long_t count)
"cursor insert")))
update_graph(cps[i]);
}
- si = free_sync_info(si);
+ free_sync_info(si);
}
else
{
@@ -3005,7 +3005,7 @@ void cursor_zeros(chan_info *cp, mus_long_t count, bool over_selection)
scale_channel(ncp, 0.0, beg, num, ncp->edit_ctr, NOT_IN_AS_ONE_EDIT);
}
}
- si = free_sync_info(si);
+ free_sync_info(si);
}
@@ -3465,7 +3465,6 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
s7_pointer arg_list, body, e, slot;
arg_list = xen_nil;
- body = xen_nil;
e = xen_nil;
slot = xen_nil;
@@ -3484,7 +3483,7 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
(res == arg))
{
/* #f = delete all samples in the range, #t = no-op, (lambda (y) y) a no-op */
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (res == s7_f(s7))
delete_samples(beg, num, cp, pos);
return(res);
@@ -3508,7 +3507,7 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
/* since we're not calling eval or the event checker, the channel can't be closed during the loop (??) */
change_samples(beg, num, data, cp, caller, pos, fabs(x));
free(data);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
return(res);
}
@@ -3541,7 +3540,7 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
change_samples(beg, num, data, cp, caller, pos, -1.0);
free(data);
}
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
return(res);
}
@@ -3587,7 +3586,7 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
}
}
s7_xf_free(s7);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
change_samples(beg, num, data, cp, caller, pos, -1.0);
free(data);
s7_set_curlet(s7, old_e);
@@ -3695,6 +3694,7 @@ static Xen map_channel_to_buffer(chan_info *cp, snd_fd *sf, Xen proc, mus_long_t
if (data) {free(data); data = NULL;}
sf = free_snd_fd(sf);
#if HAVE_SCHEME
+ free(in_data);
s7_gc_unprotect_at(s7, gc_loc);
s7_gc_unprotect_at(s7, proc_loc);
#endif
@@ -3887,7 +3887,6 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
s7_pointer body, e, slot;
arg_list = xen_nil;
- body = xen_nil;
e = xen_nil;
slot = xen_nil;
@@ -3952,7 +3951,7 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
else
{
if (reporting) finish_progress_report(cp);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
s7_xf_free(s7);
s7_set_curlet(s7, old_e);
return(C_llong_to_Xen_llong(kp + beg));
@@ -3960,7 +3959,7 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
}
}
s7_xf_free(s7);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
s7_set_curlet(s7, old_e);
if (counting)
return(C_int_to_Xen_integer(counts));
@@ -4034,7 +4033,7 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
counts++;
else
{
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (reporting)
finish_progress_report(cp);
#if HAVE_SCHEME
@@ -4069,7 +4068,7 @@ static Xen g_sp_scan(Xen proc_and_list, Xen s_beg, Xen s_end, Xen snd, Xen chn,
}
#endif
if (reporting) finish_progress_report(cp);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (counting)
return(C_int_to_Xen_integer(counts));
@@ -5435,7 +5434,7 @@ sampling-rate convert snd's channel chn by ratio, or following an envelope (a li
else sf = init_sample_read_any(beg + dur - 1, cp, READ_BACKWARD, pos);
errmsg = src_channel_with_error(cp, sf, beg, dur, ratio, egen, S_src_channel, OVER_SOUND, &clm_err);
- sf = free_snd_fd(sf);
+ free_snd_fd(sf);
if (need_free) mus_free(egen);
if (e) free_env(e);
if (errmsg)
diff --git a/snd-snd.c b/snd-snd.c
index fe387d8..6dcdc32 100644
--- a/snd-snd.c
+++ b/snd-snd.c
@@ -1658,7 +1658,7 @@ static bool apply_controls(apply_state *ap)
sp->sync = old_sync;
free(scalers);
- si = free_sync_info(si);
+ free_sync_info(si);
}
else
{
@@ -1777,7 +1777,7 @@ static bool apply_controls(apply_state *ap)
ap->ofile,
snd_open_strerror());
sp->applying = false;
- ap = free_apply_state(ap);
+ free_apply_state(ap);
return(false);
}
@@ -1886,7 +1886,7 @@ static bool apply_controls(apply_state *ap)
}
}
}
- si = free_sync_info(si);
+ free_sync_info(si);
break;
}
clear_status_area(sp);
@@ -5472,7 +5472,7 @@ If 'filename' is a sound index or a sound object, 'size' is interpreted as an ed
if (es)
{
while (!(tick_peak_env(cp, es))) {};
- es = free_env_state(es);
+ free_env_state(es);
ep = cp->edits[pos]->peak_env;
if (ep)
return(g_peak_env_info_to_vcts(ep, ep->peak_env_size));
@@ -5556,7 +5556,7 @@ If 'filename' is a sound index or a sound object, 'size' is interpreted as an ed
{
Xen vcts;
vcts = g_peak_env_info_to_vcts(ep, len);
- ep = free_peak_env_info(ep);
+ free_peak_env_info(ep);
if (peakname) free(peakname);
if (fullname) free(fullname);
return(vcts);
@@ -5603,7 +5603,7 @@ If 'filename' is a sound index or a sound object, 'size' is interpreted as an ed
}
#endif
while (!(tick_peak_env(cp, es))) {};
- es = free_env_state(es);
+ free_env_state(es);
peak = g_peak_env_info_to_vcts(cp->edits[0]->peak_env, len);
}
cp->active = CHANNEL_INACTIVE;
@@ -5901,7 +5901,7 @@ static s7_pointer acc_show_controls(s7_scheme *sc, s7_pointer args) {return(g_se
void g_init_snd(void)
{
#if HAVE_SCHEME
- s7_pointer pl_iq, pl_iqi, pl_sq, pl_sts, pl_i, pl_osi, pl_bt, pl_bo, pl_bob, pl_io, pl_ioi, pl_po, pl_pop, pl_ro, pl_ror, pl_oi, pl_ioz;
+ s7_pointer pl_iq, pl_iqi, pl_sq, pl_sts, pl_i, pl_osi, pl_bt, pl_bo, pl_bob, pl_io, pl_ioi, pl_po, pl_pop, pl_ro, pl_ror, pl_oi, pl_ioz, pl_roo, pl_roor;
{
s7_pointer i, t, s, b, o, q, p, r, z;
i = s7_make_symbol(s7, "integer?");
@@ -5930,6 +5930,8 @@ void g_init_snd(void)
pl_pop = s7_make_signature(s7, 3, p, o, p);
pl_ro = s7_make_signature(s7, 2, r, o);
pl_ror = s7_make_signature(s7, 3, r, o, r);
+ pl_roo = s7_make_signature(s7, 3, r, o, o);
+ pl_roor = s7_make_signature(s7, 4, r, o, o, r);
}
#endif
@@ -6060,7 +6062,7 @@ If it returns " PROC_TRUE ", the usual informative status babbling is squelched.
Xen_define_typed_dilambda(S_reverb_control_lowpass, g_reverb_control_lowpass_w, H_reverb_control_lowpass,
S_set S_reverb_control_lowpass, g_set_reverb_control_lowpass_w, 0, 1, 1, 1, pl_ro, pl_ror);
Xen_define_typed_dilambda(S_amp_control, g_amp_control_w, H_amp_control,
- S_set S_amp_control, g_set_amp_control_w, 0, 2, 1, 2, pl_ro, pl_ror);
+ S_set S_amp_control, g_set_amp_control_w, 0, 2, 1, 2, pl_roo,pl_roor);
Xen_define_typed_dilambda(S_amp_control_bounds, g_amp_control_bounds_w, H_amp_control_bounds,
S_set S_amp_control_bounds, g_set_amp_control_bounds_w, 0, 1, 1, 1, pl_po, pl_pop);
Xen_define_typed_dilambda(S_reverb_control_decay, g_reverb_control_decay_w, H_reverb_control_decay,
diff --git a/snd-test.scm b/snd-test.scm
index 1e3d6aa..ea493c8 100644
--- a/snd-test.scm
+++ b/snd-test.scm
@@ -1,39 +1,61 @@
;;; Snd tests
;;;
-;;; test 0: constants [420]
-;;; test 1: defaults [1090]
-;;; test 2: headers [1460]
-;;; test 3: variables [1775]
-;;; test 4: sndlib [2335]
-;;; test 5: simple overall checks [4215]
-;;; test 6: float-vectors [8940]
-;;; test 7: colors [9215]
-;;; test 8: clm [9715]
-;;; test 9: mix [21738]
-;;; test 10: marks [23516]
-;;; test 11: dialogs [24451]
-;;; test 12: extensions [24620]
-;;; test 13: menus, edit lists, hooks, etc [24884]
-;;; test 14: all together now [26170]
-;;; test 15: chan-local vars [27047]
-;;; test 16: regularized funcs [28775]
-;;; test 17: dialogs and graphics [32488]
-;;; test 18: save and restore [32599]
-;;; test 19: transforms [34229]
-;;; test 20: new stuff [36403]
-;;; test 21: optimizer [37590]
-;;; test 22: with-sound [40251]
-;;; test 23: X/Xt/Xm [43153]
-;;; test 24: GL [46773]
-;;; test 25: errors [46896]
-;;; test 26: s7 [48321]
-;;; test all done [48391]
-;;; test the end [48574]
+;;; test 0: constants [401]
+;;; test 1: defaults [1063]
+;;; test 2: headers [1436]
+;;; test 3: variables [1751]
+;;; test 4: sndlib [2314]
+;;; test 5: simple overall checks [4163]
+;;; test 6: float-vectors [8880]
+;;; test 7: colors [9146]
+;;; test 8: clm [9650]
+;;; test 9: mix [21512]
+;;; test 10: marks [23266]
+;;; test 11: dialogs [24197]
+;;; test 12: extensions [24358]
+;;; test 13: menus, edit lists, hooks, etc [24616]
+;;; test 14: all together now [25895]
+;;; test 15: chan-local vars [26762]
+;;; test 16: regularized funcs [28472]
+;;; test 17: dialogs and graphics [32169]
+;;; test 18: save and restore [32276]
+;;; test 19: transforms [33901]
+;;; test 20: new stuff [35983]
+;;; test 21: optimizer [37166]
+;;; test 22: with-sound [39734]
+;;; test 23: X/Xt/Xm [42618]
+;;; test 24: GL [46218]
+;;; test 25: errors [46339]
+;;; test 26: s7 [47753]
+;;; test all done [47822]
+;;; test the end [47994]
;;; (set! (hook-functions *load-hook*) (list (lambda (hook) (format *stderr* "loading ~S...~%" (hook 'name)))))
;(set! (*s7* 'gc-stats) #t)
+(define-macro (let-temporarily vars . body)
+ `(with-let (#_inlet :orig (#_curlet)
+ :saved (#_list ,@(map car vars))
+ :new (#_list ,@(map cadr vars)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () ; this could be (with-let orig (let ,vars , at body)) but I want to handle stuff like individual vector locations
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref new ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref new ,(set! ctr (+ ctr 1)))))))
+ vars)
+ (with-let orig , at body))
+ (lambda ()
+ ,@(map (let ((ctr -1))
+ (lambda (v)
+ (if (symbol? (car v))
+ `(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))
+ `(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))))))
+ vars)))))
+
(when (provided? 'pure-s7)
(define (make-polar mag ang)
(if (and (real? mag) (real? ang))
@@ -67,20 +89,11 @@
(if (not (defined? 'with-exit)) (define with-exit (< snd-test 0)))
(define test-number -1)
-(define-constant (snd-display-1 line . args)
- (let ((str (if (null? (cdr args))
- (car args)
- (if (or (string? (car args))
- (and (not (car args))
- (string? (cadr args))))
- (apply format #f args)
- (object->string args)))))
- (format *stderr* "~%~A: ~8T~A" line str)
- (if (not (provided? 'snd-nogui))
- (snd-print (format #f "~%~A: ~A" line str)))))
-
(define-expansion (snd-display . args)
- `(snd-display-1 ,(port-line-number) , at args))
+ `(format *stderr* "~%~A: ~8T~A" ,(port-line-number) (format #f , at args)))
+
+(define-expansion (check-edit-tree tree vals name)
+ `(check-edit-tree-1 ,tree ,vals ,name ,(port-line-number)))
(define with-big-file #f)
(define big-file-name "/home/bil/zap/sounds/bigger.snd")
@@ -139,12 +152,12 @@
(begin
(format () "copying ~A~%" file)
(copy-file (string-append home-dir "/cl/" file) (string-append (getcwd) "/" file)))))
- (list "4.aiff" "2.snd" "obtest.snd" "oboe.snd" "pistol.snd" "1a.snd" "now.snd" "fyow.snd"
- "storm.snd" "z.snd" "1.snd" "cardinal.snd" "now.snd.scm" "2a.snd" "4a.snd" "zero.snd"
- "loop.scm" "cmn-glyphs.lisp" "bullet.xpm" "mb.snd" "funcs.scm" "trumpet.snd" "1234.snd")))
+ '("4.aiff" "2.snd" "obtest.snd" "oboe.snd" "pistol.snd" "1a.snd" "now.snd" "fyow.snd"
+ "storm.snd" "z.snd" "1.snd" "cardinal.snd" "now.snd.scm" "2a.snd" "4a.snd" "zero.snd"
+ "loop.scm" "cmn-glyphs.lisp" "bullet.xpm" "mb.snd" "funcs.scm" "trumpet.snd" "1234.snd")))
-(for-each mus-sound-preload (list "4.aiff" "2.snd" "obtest.snd" "oboe.snd" "pistol.snd" "1a.snd" "now.snd"
- "fyow.snd" "storm.snd" "1.snd" "cardinal.snd" "2a.snd"))
+(for-each mus-sound-preload '("4.aiff" "2.snd" "obtest.snd" "oboe.snd" "pistol.snd" "1a.snd" "now.snd"
+ "fyow.snd" "storm.snd" "1.snd" "cardinal.snd" "2a.snd"))
@@ -200,18 +213,12 @@
(> (magnitude (- a b)) .001))
(define-constant (feql a b)
- (let ((old-eps (*s7* 'morally-equal-float-epsilon)))
- (set! (*s7* 'morally-equal-float-epsilon) .001)
- (let ((res (morally-equal? a b)))
- (set! (*s7* 'morally-equal-float-epsilon) old-eps)
- res)))
+ (let-temporarily (((*s7* 'morally-equal-float-epsilon) .001))
+ (morally-equal? a b)))
(define-constant (ffeql a b)
- (let ((old-eps (*s7* 'morally-equal-float-epsilon)))
- (set! (*s7* 'morally-equal-float-epsilon) .1)
- (let ((res (morally-equal? a b)))
- (set! (*s7* 'morally-equal-float-epsilon) old-eps)
- res)))
+ (let-temporarily (((*s7* 'morally-equal-float-epsilon) .1))
+ (morally-equal? a b)))
(define-constant (fveql a b i)
(or (null? b)
@@ -219,19 +226,13 @@
(fveql a (cdr b) (+ i 1)))))
(define* (mus-arrays-equal? x y (err .001))
- (let ((old-eps (*s7* 'morally-equal-float-epsilon)))
- (set! (*s7* 'morally-equal-float-epsilon) err)
- (let ((res (morally-equal? x y)))
- (set! (*s7* 'morally-equal-float-epsilon) old-eps)
- res)))
-
-(define-constant sd-equal mus-arrays-equal?)
-(define-constant vequal mus-arrays-equal?)
+ (let-temporarily (((*s7* 'morally-equal-float-epsilon) err))
+ (morally-equal? x y)))
-(define (vequal1 v0 v1)
+(define (mus-arrays-equal?1 v0 v1)
(mus-arrays-equal? v0 v1 .01))
-(define (vvequal v0 v1)
+(define (vmus-arrays-equal? v0 v1)
(mus-arrays-equal? v0 v1 .00002))
(define (within-.01? b) (< (abs (- 1.0 b)) .01))
@@ -662,7 +663,7 @@
(snd-display ";fft-log-magnitude set default: ~A" *fft-log-magnitude*))
(if *fft-with-phases*
(snd-display ";fft-with-phases set default: ~A" *fft-with-phases*))
- (if (not (member *transform-size* '(1024 4096)))
+ (if (not (memv *transform-size* '(1024 4096)))
(snd-display ";transform-size set default: ~A" *transform-size*))
(if (not (equal? *transform-graph-type* graph-once))
(snd-display ";transform-graph-type set default: ~A" *transform-graph-type*))
@@ -701,7 +702,7 @@
(not (eqv? (view-files-sort) 0 )))
(snd-display ";view-files-sort set default: ~A" (view-files-sort)))
- (if (not (member *print-length* '(12 32) ))
+ (if (not (memv *print-length* '(12 32) ))
(snd-display ";print-length set default: ~A" *print-length*))
(if (not (eqv? *play-arrow-size* 10 ))
(snd-display ";play-arrow-size set default: ~A" *play-arrow-size*))
@@ -763,8 +764,6 @@
(snd-display ";clm-table-size set default: ~A" *clm-table-size*))
(if (fneq *clm-default-frequency* 0.0)
(snd-display ";clm-default-frequency set default: ~A" *clm-default-frequency*))
- (if (fneq *clm-default-frequency* 0.0)
- (snd-display ";*clm-default-frequency*: ~A" *clm-default-frequency*))
(if (not (boolean? *with-verbose-cursor*))
(snd-display ";with-verbose-cursor set default: ~A" *with-verbose-cursor*))
(if (not (boolean? *with-inset-graph*))
@@ -903,7 +902,7 @@
(snd-display ";* fft-log-magnitude set default: ~A" *fft-log-magnitude*))
(if *fft-with-phases*
(snd-display ";* fft-with-phases set default: ~A" *fft-with-phases*))
- (if (not (member *transform-size* '(1024 4096)))
+ (if (not (memv *transform-size* '(1024 4096)))
(snd-display ";* transform-size set default: ~A" *transform-size*))
(if (not (equal? *transform-graph-type* graph-once))
(snd-display ";* transform-graph-type set default: ~A" *transform-graph-type*))
@@ -1031,17 +1030,13 @@
(not (= (view-files-sort) 0)))
(snd-display ";view-files-sort def: ~A" (view-files-sort)))
- (let ((old-max-malloc *mus-max-malloc*))
- (set! *mus-max-malloc* (expt 2 36))
+ (let-temporarily ((*mus-max-malloc* (expt 2 36)))
(if (not (= *mus-max-malloc* (expt 2 36)))
- (snd-display ";mus-max-malloc as bignum: ~A" *mus-max-malloc*))
- (set! *mus-max-malloc* old-max-malloc))
+ (snd-display ";mus-max-malloc as bignum: ~A" *mus-max-malloc*)))
- (let ((old-max-table-size *mus-max-table-size*))
- (set! *mus-max-table-size* (expt 2 36))
+ (let-temporarily ((*mus-max-table-size* (expt 2 36)))
(if (not (= *mus-max-table-size* (expt 2 36)))
- (snd-display ";mus-max-table-size as bignum: ~A" *mus-max-table-size*))
- (set! *mus-max-table-size* old-max-table-size))
+ (snd-display ";mus-max-table-size as bignum: ~A" *mus-max-table-size*)))
(if (not (provided? 'snd-gtk))
(for-each
@@ -1052,7 +1047,7 @@
(string=? val (func))))
(snd-display ";set ~A to bogus value: ~A ~A" name val (func)))))
(list axis-label-font axis-numbers-font tiny-font peaks-font bold-peaks-font)
- (list 'axis-label-font 'axis-numbers-font 'tiny-font 'peaks-font 'bold-peaks-font)))
+ '(axis-label-font axis-numbers-font tiny-font peaks-font bold-peaks-font)))
(set! *ask-about-unsaved-edits* #f)
(set! *remember-sound-state* #f)
@@ -1279,25 +1274,25 @@
(star-name (args 4)))
(setfnc newval)
(let ((nowval (symbol->value star-name)))
- (if (not (or (equal? newval nowval)
- (and (list? newval)
- (feql newval nowval))))
- (if (and (number? newval) (not (rational? newval)))
- (if (> (abs (- newval nowval)) .01)
- (snd-display ";~A is not ~A (~A)" star-name newval nowval))
- (snd-display ";~A is not ~A (~A)" star-name newval nowval)))
+ (if (and (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
+ (or (not (number? newval))
+ (rational? newval)
+ (> (abs (- newval nowval)) 0.01)))
+ (snd-display ";~A is not ~A (~A)" star-name newval nowval))
(eval `(set! ,star-name ,initval))
(if (not (morally-equal? (getfnc) initval))
(snd-display ";* ~A is not ~A" name initval))
(eval `(set! ,star-name ,newval))
(let ((nowval (getfnc)))
- (if (not (or (equal? newval nowval)
- (and (list? newval)
- (feql newval nowval))))
- (if (and (number? newval) (not (rational? newval)))
- (if (> (abs (- newval nowval)) .01)
- (snd-display ";set! ~A is not ~A (~A)" star-name newval nowval))
- (snd-display ";set! ~A is not ~A (~A)" star-name newval nowval)))
+ (if (and (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
+ (or (not (number? newval))
+ (rational? newval)
+ (> (abs (- newval nowval)) 0.01)))
+ (snd-display ";set! ~A is not ~A (~A)" star-name newval nowval))
(setfnc initval))
(test-vars (cdr lst))))))))
(test-vars
@@ -1444,12 +1439,12 @@
(if (not (file-exists? file))
(snd-display ";~A missing?" file)
(begin
- (if (not (equal? (mus-sound-chans file) (testf 1)))
+ (if (not (eqv? (mus-sound-chans file) (testf 1)))
(snd-display ";~A: chans ~A is not ~A"
(testf 0)
(mus-sound-chans file)
(testf 1)))
- (if (not (equal? (mus-sound-srate file) (testf 2)))
+ (if (not (eqv? (mus-sound-srate file) (testf 2)))
(snd-display ";~A: srate ~A is not ~A"
(testf 0)
(mus-sound-srate file)
@@ -1735,8 +1730,8 @@
(if (not (string=? (file-name ind) real-name))
(snd-display ";expand file name ~A: ~A" in-name (file-name ind)))
(close-sound ind))))))
- (list "/home/bil/./sf1/o2.voc" "~/./sf1/o2.voc" "~/cl/../sf1/o2.voc" "/home/bil/cl/../sf1/o2.voc")
- (list "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc"))
+ '("/home/bil/./sf1/o2.voc" "~/./sf1/o2.voc" "~/cl/../sf1/o2.voc" "/home/bil/cl/../sf1/o2.voc")
+ '("/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc" "/home/bil/sf1/o2.voc"))
(let ((lst (mus-sound-mark-info (string-append sf-dir "forest.aiff"))))
(if (not (equal? lst '((4 0) (3 0) (2 144332) (1 24981))))
@@ -1773,7 +1768,7 @@
(snd-display ";enved-dialog -> ~A ~A" wid ((dialog-widgets) 1))))
;(if (not ((dialog-widgets) 1)) (snd-display ";enved-dialog?"))
(set! (enved-envelope) '(0.0 0.0 1.0 1.0 2.0 0.0))
- (if (not (equal? (enved-envelope) (list 0.0 0.0 1.0 1.0 2.0 0.0)))
+ (if (not (equal? (enved-envelope) '(0.0 0.0 1.0 1.0 2.0 0.0)))
(snd-display ";set enved-envelope to self: ~A?" (enved-envelope)))
(letrec ((test-vars
@@ -1787,23 +1782,23 @@
(setfnc newval)
(let ((nowval (getfnc)))
- (if (not (or (equal? newval nowval)
- (and (list? newval)
- (feql newval nowval))))
- (if (and (number? newval) (not (rational? newval)))
- (if (> (abs (- newval nowval)) .01)
- (snd-display ";~A is not ~A (~A)" name newval nowval))
- (snd-display ";~A is not ~A (~A)" name newval nowval)))
+ (if (and (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
+ (or (not (number? newval))
+ (rational? newval)
+ (> (abs (- newval nowval)) 0.01)))
+ (snd-display ";~A is not ~A (~A)" name newval nowval))
(setfnc initval)
(set! (getfnc) newval)
(let ((nowval (getfnc)))
- (if (not (or (equal? newval nowval)
- (and (list? newval)
- (feql newval nowval))))
- (if (and (number? newval) (not (rational? newval)))
- (if (> (abs (- newval nowval)) .01)
- (snd-display ";set! ~A is not ~A (~A)" name newval nowval))
- (snd-display ";set! ~A is not ~A (~A)" name newval nowval)))
+ (if (and (not (or (equal? newval nowval)
+ (and (list? newval)
+ (feql newval nowval))))
+ (or (not (number? newval))
+ (rational? newval)
+ (> (abs (- newval nowval)) 0.01)))
+ (snd-display ";set! ~A is not ~A (~A)" name newval nowval))
(setfnc initval))
(test-vars (cdr lst))))))))
(test-vars
@@ -2348,12 +2343,12 @@
(if (not (string=? (mus-header-type->string mus-aifc) "mus-aifc"))
(snd-display ";mus-header-type->string: ~A" (mus-header-type->string mus-aifc)))
(mus-sound-report-cache "hiho.tmp")
- (let ((p (open-input-file "hiho.tmp")))
- (let ((line (read-line p)))
- (if (not (member line '("sound table:" "sound table:\n")))
- (snd-display ";print-cache 1: ~A?" line))
- (close-input-port p)
- (delete-file "hiho.tmp")))
+ (let* ((p (open-input-file "hiho.tmp"))
+ (line (read-line p)))
+ (if (not (member line '("sound table:" "sound table:\n")))
+ (snd-display ";print-cache 1: ~A?" line))
+ (close-input-port p)
+ (delete-file "hiho.tmp"))
(let ((chns (mus-sound-chans "oboe.snd")))
(if (not (= chns 1)) (snd-display ";oboe: mus-sound-chans ~D?" chns)))
(if (= clmtest 0)
@@ -2381,7 +2376,7 @@
(if (= clmtest 0)
(let ((vals (mus-header-raw-defaults)))
- (if (not (and (list? vals)
+ (if (not (and (pair? vals)
(= (length vals) 3)))
(snd-display ";mus-header-raw-defaults: ~A" vals)
(let ((sr (car vals))
@@ -2392,7 +2387,7 @@
(if (not (= frm mus-bshort)) (snd-display ";mus-header-raw-defaults format: ~A: ~A" frm (mus-sample-type-name frm)))))))
(set! (mus-header-raw-defaults) (list 12345 3 mus-bdouble-unscaled))
(let ((vals (mus-header-raw-defaults)))
- (if (not (and (list? vals)
+ (if (not (and (pair? vals)
(= (length vals) 3)))
(snd-display ";set mus-header-raw-defaults: ~A" vals)
(let ((sr (car vals))
@@ -2435,20 +2430,19 @@
(mus-sound-forget long-file-name)
(delete-file long-file-name))
- (let ((old-sound-path *mus-sound-path*)
- (new-path (if (provided? 'osx) "/Users/bil/sf1" "/home/bil/sf1")))
- (set! *mus-sound-path* (list new-path))
- (let ((ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f))))
- (if (not (sound? ind))
- (snd-display ";*mus-sound-path*: ~A~%" ind)
- (begin
- (close-sound ind)
- (set! (mus-sound-path) (list new-path))
- (set! ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f)))
- (if (sound? ind)
- (close-sound ind)
- (snd-display ";(mus-sound-path): ~A~%" ind)))))
- (set! *mus-sound-path* old-sound-path))
+
+ (let ((new-path (if (provided? 'osx) "/Users/bil/sf1" "/home/bil/sf1")))
+ (let-temporarily ((*mus-sound-path* (list new-path)))
+ (let ((ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f))))
+ (if (not (sound? ind))
+ (snd-display ";*mus-sound-path*: ~A~%" ind)
+ (begin
+ (close-sound ind)
+ (set! (mus-sound-path) (list new-path))
+ (set! ind (catch #t (lambda () (open-sound "o2.bicsf")) (lambda args #f)))
+ (if (sound? ind)
+ (close-sound ind)
+ (snd-display ";(mus-sound-path): ~A~%" ind)))))))
(let ((fsnd (string-append sf-dir "forest.aiff")))
(if (file-exists? fsnd)
@@ -2458,11 +2452,11 @@
(if (not (equal? (sound-loop-info index) (mus-sound-loop-info fsnd)))
(snd-display ";loop-info: ~A ~A" (sound-loop-info index) (mus-sound-loop-info fsnd)))
(set! (sound-loop-info index) (list 12000 14000 1 2 3 4))
- (if (not (equal? (sound-loop-info index) (list 12000 14000 1 2 3 4 1 1)))
+ (if (not (equal? (sound-loop-info index) '(12000 14000 1 2 3 4 1 1)))
(snd-display ";set loop-info: ~A" (sound-loop-info index)))
(save-sound-as "fmv1.snd" index :header-type mus-aifc)
(close-sound index)
- (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 12000 14000 1 2 3 4 1 1)))
+ (if (not (equal? (mus-sound-loop-info "fmv1.snd") '(12000 14000 1 2 3 4 1 1)))
(snd-display ";saved loop-info: ~A" (mus-sound-loop-info "fmv1.snd")))))))
(let ((index (open-sound "oboe.snd")))
(save-sound-as "fmv.snd" index :header-type mus-aifc)
@@ -2471,19 +2465,19 @@
(if (not (null? (sound-loop-info index)))
(snd-display ";null loop-info: ~A" (sound-loop-info index)))
(set! (sound-loop-info index) (list 1200 1400 4 3 2 1))
- (if (not (equal? (sound-loop-info index) (list 1200 1400 4 3 2 1 1 1)))
+ (if (not (equal? (sound-loop-info index) '(1200 1400 4 3 2 1 1 1)))
(snd-display ";set null loop-info: ~A" (sound-loop-info index)))
(save-sound-as "fmv1.snd" :sound index :header-type mus-aifc)
(close-sound index)
- (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 1200 1400 4 3 2 1 1 1)))
+ (if (not (equal? (mus-sound-loop-info "fmv1.snd") '(1200 1400 4 3 2 1 1 1)))
(snd-display ";saved null loop-info: ~A" (mus-sound-loop-info "fmv1.snd"))))
(let ((index (open-sound "fmv.snd")))
(set! (sound-loop-info) (list 1200 1400 4 3 2 1 1 0))
- (if (not (equal? (sound-loop-info index) (list 1200 1400 0 0 2 1 1 0)))
+ (if (not (equal? (sound-loop-info index) '(1200 1400 0 0 2 1 1 0)))
(snd-display ";set null loop-info (no mode1): ~A" (sound-loop-info index)))
(save-sound-as "fmv1.snd" index :header-type mus-aifc)
(close-sound index)
- (if (not (equal? (mus-sound-loop-info "fmv1.snd") (list 1200 1400 0 0 2 1 1 0)))
+ (if (not (equal? (mus-sound-loop-info "fmv1.snd") '(1200 1400 0 0 2 1 1 0)))
(snd-display ";saved null loop-info (no mode1): ~A" (mus-sound-loop-info "fmv1.snd"))))
(let ((com (mus-sound-comment "oboe.snd")))
@@ -2608,18 +2602,18 @@
(let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "set-samples test" 100)))
(set! (samples 10 3) (make-float-vector 3 .1))
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
(snd-display ";1 set samples 0 for .1: ~A" (channel->float-vector 0 20 ind 0)))
(set! (samples 20 3 ind 0) (make-float-vector 3 .1))
- (if (not (vequal (channel->float-vector 10 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
(snd-display ";2 set samples 10 for .1: ~A" (channel->float-vector 10 20 ind 0)))
(set! (samples 30 3 ind 0 #f "a name") (make-float-vector 3 .1))
- (if (not (vequal (channel->float-vector 20 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 20 20 ind 0) (float-vector .1 .1 .1 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
(snd-display ";3 set samples 20 for .1: ~A" (channel->float-vector 20 20 ind 0)))
(set! (samples 0 3 ind 0 #f "a name" 0 1) (make-float-vector 3 .2))
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .2 .2 .2 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0) (float-vector .2 .2 .2 0 0 0 0 0 0 0 .1 .1 .1 0 0 0 0 0 0 0)))
(snd-display ";4 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
- (if (not (vequal (channel->float-vector 20 20 ind 0) (make-float-vector 20 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 20 20 ind 0) (make-float-vector 20)))
(snd-display ";5 set samples 20 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
(let ((nd (new-sound "fmv1.snd" :channels 2)))
(float-vector->channel (make-float-vector 10 .5) 0 10 nd 0)
@@ -2628,20 +2622,20 @@
(close-sound nd))
(if (not (file-exists? "fmv1.snd")) (snd-display ";fmv1 not saved??"))
(set! (samples 0 10 ind 0 #f "another name" 1) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 .1 .1 .1 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 .1 .1 .1 0 0 0 0 0 0 0)))
(snd-display ";6 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
(set! (samples 5 6 ind 0 #f "another name 7" 0) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .5 .5 .5 .5 .5 .5 .1 .1 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .5 .5 .5 .5 .5 .5 .1 .1 0 0 0 0 0 0 0)))
(snd-display ";7 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
(revert-sound ind)
(set! (samples 0 10 ind 0 #f "another name 8" 1 0 #f) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0) (float-vector .3 .3 .3 .3 .3 .3 .3 .3 .3 .3 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";8 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
(set! (samples 10 10 ind 0 #f "another name 9" 0 0) "fmv1.snd")
- (if (not (vequal (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0) (float-vector 0 0 0 0 0 0 0 0 0 0 .5 .5 .5 .5 .5 .5 .5 .5 .5 .5)))
(snd-display ";9 set samples 0 at 1 for .1: ~A" (channel->float-vector 0 20 ind 0)))
(set! (samples 20 10) "fmv1.snd")
- (if (not (vequal (channel->float-vector 10 20 ind 0) (make-float-vector 20 .5)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 20 ind 0) (make-float-vector 20 .5)))
(snd-display ";10 set samples 0 at 1 for .1: ~A" (channel->float-vector 10 20 ind 0)))
(revert-sound ind)
(set! (samples 0 10 ind 0 #t "another name" 1 0 #f) "fmv1.snd")
@@ -2788,11 +2782,10 @@
(if (not (= (mus-sound-sample-type "test.snd") mus-lfloat))
(snd-display ";saved-as float -> ~A?" (mus-sample-type-name (mus-sound-sample-type "test.snd"))))
(if (fneq (sample 1000 ab) samp) (snd-display ";riff[1000] = ~A?" (sample 1000 ab)))
- (if (not (and (string? (comment ab))
- (string=? (comment ab)
- (string-append "written "
- (strftime "%a %d-%b-%Y %H:%M %Z" (localtime (current-time)))
- " [written by me]"))))
+ (if (not (equal? (comment ab)
+ (string-append "written "
+ (strftime "%a %d-%b-%Y %H:%M %Z" (localtime (current-time)))
+ " [written by me]")))
(snd-display ";output-comment-hook: ~A~%(~A)" (comment ab) (mus-sound-comment "test.snd")))
(close-sound ab))
(save-sound-as "test.snd" ob :header-type mus-aiff :sample-type mus-b24int)
@@ -2856,15 +2849,15 @@
(if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd"))) ; these set!'s can change the index via update-sound
(if (not (= (sample-type ab) mus-lshort)) (snd-display ";set sample-type: ~A?" (mus-sample-type-name (sample-type ab))))
(when (and with-gui
- (not (equal? (y-bounds ab 0) (list -3.0 3.0))))
+ (not (equal? (y-bounds ab 0) '(-3.0 3.0))))
(snd-display ";set sample type y-bounds: ~A?" (y-bounds ab 0)))
(set! (y-bounds ab 0) (list 2.0))
(when (and with-gui
- (not (equal? (y-bounds ab 0) (list -2.0 2.0))))
+ (not (equal? (y-bounds ab 0) '(-2.0 2.0))))
(snd-display ";set sample type y-bounds 1: ~A?" (y-bounds ab 0)))
(set! (y-bounds ab 0) (list -2.0))
(when (and with-gui
- (not (equal? (y-bounds ab 0) (list -2.0 2.0))))
+ (not (equal? (y-bounds ab 0) '(-2.0 2.0))))
(snd-display ";set sample type y-bounds -2: ~A?" (y-bounds ab 0)))
(set! (header-type ab) mus-aifc)
(if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
@@ -2875,11 +2868,9 @@
(set! (data-location ab) 1234)
(if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
(if (not (= (data-location ab) 1234)) (snd-display ";set data-location: ~A?" (data-location ab)))
- (let ((old-size (data-size ab)))
- (set! (data-size ab) 1234)
+ (let-temporarily (((data-size ab) 1234))
(if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
- (if (not (= (data-size ab) 1234)) (snd-display ";set data-size: ~A?" (data-size ab)))
- (set! (data-size ab) old-size))
+ (if (not (= (data-size ab) 1234)) (snd-display ";set data-size: ~A?" (data-size ab))))
(set! (srate ab) 12345)
(if (not (equal? ab (find-sound "test.snd"))) (set! ab (find-sound "test.snd")))
(if (not (= (srate ab) 12345)) (snd-display ";set srate: ~A?" (srate ab)))
@@ -3031,17 +3022,17 @@
(string-append sf-dir "bad_chans.nist")
(string-append sf-dir "bad_srate.nist")
(string-append sf-dir "bad_length.nist"))
- (list (list 0 22050 0)
- (list 1 0 0)
- (list 1 22050 4411)
- (list 0 22050 0)
- (list 1 0 0)
- (list 1 22050 -10)
- (list 0 22050 0)
- (list 1 0 0)
- (list 0 22050 0)
- (list 1 0 0)
- (list 1 22050 -10)))
+ '((0 22050 0)
+ (1 0 0)
+ (1 22050 4411)
+ (0 22050 0)
+ (1 0 0)
+ (1 22050 -10)
+ (0 22050 0)
+ (1 0 0)
+ (0 22050 0)
+ (1 0 0)
+ (1 22050 -10)))
(let ((ind (open-sound (string-append "/usr/include/sys/" home-dir "/cl/oboe.snd"))))
(if (not (and (sound? ind)
@@ -3103,8 +3094,8 @@
(lambda args args))))
(if (not (eq? (car tag) 'mus-error))
(snd-display ";open-sound ~A: ~A" file tag))))
- (list "trunc.snd" "trunc.aiff" "trunc.wav" "trunc.sf" "trunc.voc" "trunc.nist" "bad.wav"
- "trunc1.aiff" "badform.aiff"))
+ '("trunc.snd" "trunc.aiff" "trunc.wav" "trunc.sf" "trunc.voc" "trunc.nist" "bad.wav"
+ "trunc1.aiff" "badform.aiff"))
(hook-push open-raw-sound-hook (lambda (hook) (set! (hook 'result) (list 1 22050 mus-bshort))))
(let ((ind (open-sound (string-append sf-dir "empty.snd"))))
@@ -3117,20 +3108,20 @@
(set! (hook-functions open-raw-sound-hook) ())
(close-sound ind))
- (let ((sd (make-float-vector (list 1 1) 0.0)))
+ (let ((sd (make-float-vector '(1 1))))
(if (fneq (sd 0 0) 0.0) (snd-display ";vector2 ref: ~A" (sd 0 0)))
(set! (sd 0 0) 1.0)
(if (fneq (sd 0 0) 1.0) (snd-display ";vector2 set: ~A" (sd 0 0)))
- (if (not (equal? sd (let ((sd1 (make-float-vector (list 1 1) 0.0))) (vector-set! sd1 0 0 1.0) sd1)))
+ (if (not (equal? sd (let ((sd1 (make-float-vector '(1 1)))) (vector-set! sd1 0 0 1.0) sd1)))
(snd-display ";vector2 set not equal: ~A" sd)))
- (let ((sd (make-float-vector (list 2 3) 0.0)))
+ (let ((sd (make-float-vector '(2 3))))
(if (fneq (sd 0 0) 0.0) (snd-display ";vector2 ref (1): ~A" (sd 0 0)))
(set! (sd 1 0) 1.0)
(if (fneq (sd 1 0) 1.0) (snd-display ";vector2 set (1 0): ~A" (sd 1 0)))
(set! (sd 1 2) 2.0)
(if (fneq (sd 1 2) 2.0) (snd-display ";vector2 set (1 2): ~A" (sd 1 2)))
- (if (not (equal? sd (let ((sd1 (make-float-vector (list 2 3) 0.0)))
+ (if (not (equal? sd (let ((sd1 (make-float-vector '(2 3))))
(vector-set! sd1 1 0 1.0)
(vector-set! sd1 1 2 2.0)
sd1)))
@@ -3194,7 +3185,7 @@
(close-sound snd))
(let ((snd (open-sound "test.snd")))
(let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 1.000 -1.000 1.000 0.000 0.000 -0.700 0.700 -0.200 0.200)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 1.000 -1.000 1.000 0.000 0.000 -0.700 0.700 -0.200 0.200)))
(snd-display ";unclipped 1: ~A" data)))
(close-sound snd))
(mus-sound-forget "test.snd")
@@ -3215,7 +3206,7 @@
(close-sound snd))
(let ((snd (open-sound "test.snd")))
(let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 1.000 -1.000 1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 1.000 -1.000 1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
(snd-display ";clipped: ~A" data)))
(close-sound snd))
(set! *clipping* #f)
@@ -3225,7 +3216,7 @@
(lambda ()
(let* ((ind (open-sound file))
(ndata (channel->float-vector beg dur ind 0)))
- (if (not (vequal data ndata))
+ (if (not (mus-arrays-equal? data ndata))
(snd-display ";~A: ~A != ~A" file data ndata))
(close-sound ind)))
(lambda args args)))))
@@ -3373,7 +3364,7 @@
(set! (mus-sound-data-location file) cur-loc)
(set! (mus-sound-header-type file) cur-type)
(set! (mus-sound-sample-type file) cur-format)))
- (list "test.wave" "test.rf64" "test.aifc"))
+ '("test.wave" "test.rf64" "test.aifc"))
(for-each
(lambda (file)
@@ -3414,7 +3405,7 @@
(close-sound ind))
(if (file-exists? file)
(delete-file file)))
- (list "test.wave" "test.rf64" "test.aifc")))
+ '("test.wave" "test.rf64" "test.aifc")))
;; (with-sound (big-file-name :srate 44100 :play #f)
;; (do ((i 0 (+ i 1))) ((= i 72000))
@@ -3442,27 +3433,25 @@
(set! (mark-sample m1) (* (floor *clm-srate*) 66000))
(if (not (= (mark-sample m1) (* (floor *clm-srate*) 66000))) (snd-display ";bigger mark to: ~A" (mark-sample m1))))
(let ((mx (mix-sound "oboe.snd" (* (floor *clm-srate*) 60000))))
- (if (mix? mx)
+ (if (not (mix? mx))
+ (snd-display ";no mix tag from mix-sound")
(begin
(if (not (= (mix-position mx) (* (floor *clm-srate*) 60000))) (snd-display ";bigger mix at: ~A" (mix-position mx)))
(set! (mix-position mx) (* (floor *clm-srate*) 61000))
- (if (not (= (mix-position mx) (* (floor *clm-srate*) 61000))) (snd-display ";bigger mix to: ~A" (mix-position mx))))
- (snd-display ";no mix tag from mix-sound"))
+ (if (not (= (mix-position mx) (* (floor *clm-srate*) 61000))) (snd-display ";bigger mix to: ~A" (mix-position mx)))))
(undo 2))
(let ((res (scan-channel (lambda (y) (> (abs y) 0.0)))))
- (if (or (not res)
+ (if (or (not (pair? res))
(> (cadr res) 100))
(snd-display ";bigger find not 0.0: ~A" res)))
- (let ((old-select *selection-creates-region*))
- (set! *selection-creates-region* #f)
+ (let-temporarily ((*selection-creates-region* #f))
(select-all ind)
(if (not (= (selection-framples) (framples ind))) (snd-display ";bigger select all: ~A ~A" (selection-framples) (framples)))
(set! (selection-position) (* (floor *clm-srate*) 50000))
(if (not (= (selection-position) (* (floor *clm-srate*) 50000))) (snd-display ";bigger select pos: ~A" (selection-position)))
(set! (selection-position) 0)
(set! (selection-framples) (* (floor *clm-srate*) 65000))
- (if (not (= (selection-framples) (* (floor *clm-srate*) 65000))) (snd-display ";bigger select len: ~A" (selection-framples)))
- (set! *selection-creates-region* old-select))
+ (if (not (= (selection-framples) (* (floor *clm-srate*) 65000))) (snd-display ";bigger select len: ~A" (selection-framples))))
(let ((size 2260597782) ;(* 44123 51234))
(msize 2701827782)) ;(* 44123 61234)
(set! (cursor ind) (* (floor *clm-srate*) 50000))
@@ -3471,56 +3460,54 @@
(if (not (= (mark-sample m1) size)) (snd-display ";bigger mark at: ~A" (mark-sample m1)))
(let ((mid (find-mark size)))
(if (not (and (number? mid) (= mid m1))) (snd-display ";bigger mark seach: ~A ~A" mid m1))))
- (let ((mx (mix-sound "oboe.snd" msize)))
- (let ((mxd (find-mix msize)))
- (if (not (and (number? mxd) (= mxd mx))) (snd-display ";bigger find-mix ~A ~A" mxd mx))))
+ (let* ((mx (mix-sound "oboe.snd" msize))
+ (mxd (find-mix msize)))
+ (if (not (and (number? mxd) (= mxd mx))) (snd-display ";bigger find-mix ~A ~A" mxd mx)))
(set! (cursor ind) size)
(if (not (= (cursor ind) size)) (snd-display ";bigger cursor 123: ~A" (cursor ind))))
(close-sound ind))))
- (let ((ind (new-sound "tmp.snd" 1 22050 mus-l24int mus-riff :size 100000))
- (old-selection-creates-region *selection-creates-region*))
- (set! *selection-creates-region* #t)
- (let ((incr (/ 1.0 (framples)))
- (data (make-float-vector (framples))))
- (outa->fv data (- (* i incr) 0.5))
- (float-vector->channel data))
- (save-sound)
- (close-sound ind)
- (set! ind (open-sound "tmp.snd"))
- (let ((reg (select-all))
- (v1 (make-float-vector 100000)))
- (save-selection "tmp1.snd" 22050 mus-l24int mus-next)
- (let ((ind1 (open-sound "tmp1.snd")))
- (let ((incr (/ 1.0 (framples))))
- (outa->fv v1 (- (* i incr) 0.5))
- (let ((v0 (samples 0 100000 ind1 0)))
- (if (not (vequal v0 v1))
- (snd-display ";l24 (next) selection not saved correctly? ~A" v0))))
- (close-sound ind1))
-
- (save-selection "tmp1.snd" 22050 mus-l24int mus-aifc)
- (let ((ind1 (open-sound "tmp1.snd")))
- (let ((v0 (samples 0 100000 ind1 0)))
- (if (not (vequal v0 v1))
- (snd-display ";l24 (aifc) selection not saved correctly? ~A" v0)))
- (close-sound ind1))
-
- (save-region reg "tmp1.snd" mus-l24int mus-next)
- (let ((ind1 (open-sound "tmp1.snd")))
- (let ((v0 (samples 0 100000 ind1 0)))
- (if (not (vequal v0 v1))
- (snd-display ";l24 (next) region not saved correctly? ~A" v0)))
- (close-sound ind1))
- (delete-file "tmp1.snd")
+ (let ((ind (new-sound "tmp.snd" 1 22050 mus-l24int mus-riff :size 100000)))
+ (let-temporarily ((*selection-creates-region* #t))
+ (let ((incr (/ 1.0 (framples)))
+ (data (make-float-vector (framples))))
+ (outa->fv data (- (* i incr) 0.5))
+ (float-vector->channel data))
+ (save-sound)
(close-sound ind)
- (delete-file "tmp.snd"))
- (set! *selection-creates-region* old-selection-creates-region))
+ (set! ind (open-sound "tmp.snd"))
+ (let ((reg (select-all))
+ (v1 (make-float-vector 100000)))
+ (save-selection "tmp1.snd" 22050 mus-l24int mus-next)
+ (let ((ind1 (open-sound "tmp1.snd")))
+ (let ((incr (/ 1.0 (framples))))
+ (outa->fv v1 (- (* i incr) 0.5))
+ (let ((v0 (samples 0 100000 ind1 0)))
+ (if (not (mus-arrays-equal? v0 v1))
+ (snd-display ";l24 (next) selection not saved correctly? ~A" v0))))
+ (close-sound ind1))
+
+ (save-selection "tmp1.snd" 22050 mus-l24int mus-aifc)
+ (let ((ind1 (open-sound "tmp1.snd")))
+ (let ((v0 (samples 0 100000 ind1 0)))
+ (if (not (mus-arrays-equal? v0 v1))
+ (snd-display ";l24 (aifc) selection not saved correctly? ~A" v0)))
+ (close-sound ind1))
+
+ (save-region reg "tmp1.snd" mus-l24int mus-next)
+ (let ((ind1 (open-sound "tmp1.snd")))
+ (let ((v0 (samples 0 100000 ind1 0)))
+ (if (not (mus-arrays-equal? v0 v1))
+ (snd-display ";l24 (next) region not saved correctly? ~A" v0)))
+ (close-sound ind1))
+ (delete-file "tmp1.snd")
+ (close-sound ind)
+ (delete-file "tmp.snd"))))
(let ((ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 10 :comment #f)))
(map-channel (lambda (y) 1.0))
(env-channel '(0 0 .1 .1 .2 .2 .3 .3 .4 .4 .5 .5 .6 .6 .7 .7 .8 .8 .9 .9))
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
(snd-display ";ramp env by .1: ~A" (channel->float-vector)))
(close-sound ind))
)
@@ -3940,8 +3927,7 @@
(if (fneq (sample 1) 0.50195) (snd-display ";file chunked 1: ~A" (sample 1)))
(if (fneq (sample 2) 0.0) (snd-display ";file chunked eof: ~A" (sample 2)))
(if (fneq (sample 3) 0.0) (snd-display ";file chunked eof+1: ~A" (sample 3)))
- (if (not (and (string? (comment))
- (string=? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")))
+ (if (not (equal? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98"))
(snd-display ";chunked appl comment: ~A" (comment)))
(close-sound file)))
(lambda args (snd-display ";~S" args)))
@@ -3980,8 +3966,7 @@
(if (fneq (sample 0 file 1) 0.50195) (snd-display ";file chunked 0 1: ~A" (sample 0 file 1)))
(if (fneq (sample 1 file 0) 0.0) (snd-display ";file chunked eof (stereo): ~A" (sample 1 file 0)))
(if (fneq (sample 1 file 1) 0.0) (snd-display ";file chunked eof+1 (stereo): ~A" (sample 1 file 1)))
- (if (not (and (string? (comment))
- (string=? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98")))
+ (if (not (equal? (comment) ";Written Mon 02-Nov-98 01:44 CST by root at ockeghem (Linux/X86) using Allegro CL, clm of 20-Oct-98"))
(snd-display ";chunked appl comment (stereo): ~A" (comment)))
(close-sound file)))
(lambda args (snd-display ";~S" args)))
@@ -4079,11 +4064,9 @@
(unless (provided? 'gmp)
(let* ((LONG_MAX 2147483647)
(LONG_MIN -2147483648)
- (LLONG_MAX most-positive-fixnum)
- (LLONG_MIN most-negative-fixnum)
(ints (list 0 1 -1 10 -10 1234 -1234 LONG_MAX LONG_MIN 65536 -65536))
(shorts (list 0 1 -1 10 -10 1234 -1234 32767 -32768 8191 -8191))
- (longs (list 0 1 -1 11 -11 LONG_MAX LONG_MIN LLONG_MAX LLONG_MIN 1000 -1000))
+ (longs (list 0 1 -1 11 -11 LONG_MAX LONG_MIN most-positive-fixnum most-negative-fixnum 1000 -1000))
(floats (list 0.0 1.0 -1.0 0.1 -0.1 10.0 -10.0 1234.0 65536.0 -1234.0 -0.003))
(doubles (list 0.0 1.0 -1.0 0.1 -0.1 10.0 -10.0 1234.0 65536.0 -1234.0 -0.003)))
(load "binary-io.scm")
@@ -4167,6 +4150,9 @@
(require snd-selection.scm snd-extensions.scm snd-selection.scm snd-dsp.scm snd-pvoc.scm)
(if with-gui (require snd-edit-menu.scm))
+(define-expansion (check-maxamp ind val name)
+ `(check-maxamp-1 ,(port-line-number) ,ind ,val ,name))
+
(define (snd_test_5)
(define a-ctr 0)
@@ -4191,11 +4177,11 @@
(let ((v0 (channel->float-vector 12000 10 ind1 0)))
(test-func ind1 0)
(let ((v1 (channel->float-vector 12000 10 ind1 0)))
- (if (vequal v0 v1)
+ (if (mus-arrays-equal? v0 v1)
(snd-display ";~A (0) no change! ~A ~A" func-name v0 v1))
(test-func ind1 0)
(let ((v2 (channel->float-vector 12000 10 ind1 0)))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";~A (1) ~A ~A" func-name v1 v2)))))
(revert-sound ind1))
@@ -4203,11 +4189,11 @@
(let ((v0 (channel->float-vector 12000 10 ind1 0)))
(func0 ind1)
(let ((v1 (channel->float-vector 12000 10 ind1 0)))
- (if (vequal1 v0 v1)
+ (if (mus-arrays-equal?1 v0 v1)
(snd-display ";~A (orig: 0) no change! ~A ~A" func-name v0 v1))
(func1 ind1)
(let ((v2 (channel->float-vector 12000 10 ind1 0)))
- (if (not (vequal1 v0 v2))
+ (if (not (mus-arrays-equal?1 v0 v2))
(snd-display ";~A (orig: 1) ~A ~A" func-name v0 v2))))
(revert-sound ind1)))
@@ -4217,9 +4203,6 @@
(float-vector-add! (mus-xcoeffs f1) (mus-xcoeffs f2))
f1))
- (define-expansion (check-maxamp ind val name)
- `(check-maxamp-1 ,(port-line-number) ,ind ,val ,name))
-
(define (check-maxamp-1 caller-line ind val name)
(if (fneq (maxamp ind 0) val) (snd-display ";maxamp amp-env ~A: ~A should be ~A" name (maxamp ind) val))
(let ((pos (scan-channel (lambda (y) (>= (abs y) (- val .0001)))))
@@ -4290,17 +4273,17 @@
(float-vector->channel (make-float-vector 10 1.0))
(env-channel '(0 0 1 1 2 0))
(let ((data (channel->float-vector)))
- (if (not (vequal data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";pyr 10: ~A" data)))
(undo)
(env-channel '((0 0) (1 1) (2 0)))
(let ((data (channel->float-vector)))
- (if (not (vequal data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";pyr 10: ~A" data)))
(undo)
(env-channel (make-env '(0 0 1 1 2 0) :length 10))
(let ((data (channel->float-vector)))
- (if (not (vequal data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";pyr 10: ~A" data)))
(undo)
(close-sound ind))
@@ -4358,47 +4341,47 @@
(snd-display ";ramp-channel ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval)))))
(undo)
(xramp-channel 0.0 1.0 32.0)
- (let ((e (make-env '(0 0 1 1) :length size :base 32.0)))
- (let ((data (channel->float-vector)))
- (if (or (fneq (data 0) 0.0)
- (fneq (data (- size 1)) 1.0))
- (snd-display ";xramp-channel 32 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
- (do ((i 0 (+ i 1)))
- ((= i size))
- (let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0) 32.0))
- (segval (env e)))
- (if (or (fneq segval val)
- (fneq (data i) val))
- (snd-display ";xramp-channel 32 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval))))))
+ (let* ((e (make-env '(0 0 1 1) :length size :base 32.0))
+ (data (channel->float-vector)))
+ (if (or (fneq (data 0) 0.0)
+ (fneq (data (- size 1)) 1.0))
+ (snd-display ";xramp-channel 32 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (do ((i 0 (+ i 1)))
+ ((= i size))
+ (let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0) 32.0))
+ (segval (env e)))
+ (if (or (fneq segval val)
+ (fneq (data i) val))
+ (snd-display ";xramp-channel 32 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval)))))
(undo)
(xramp-channel 0.0 1.0 0.4)
- (let ((e (make-env '(0 0 1 1) :length size :base 0.4)))
- (let ((data (channel->float-vector)))
- (if (or (fneq (data 0) 0.0)
- (fneq (data (- size 1)) 1.0))
- (snd-display ";xramp-channel .4 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
- (do ((i 0 (+ i 1)))
- ((= i size))
- (let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0) 0.4))
- (segval (env e)))
- (if (or (fneq segval val)
- (fneq (data i) val))
- (snd-display ";xramp-channel .4 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval))))))
+ (let* ((e (make-env '(0 0 1 1) :length size :base 0.4))
+ (data (channel->float-vector)))
+ (if (or (fneq (data 0) 0.0)
+ (fneq (data (- size 1)) 1.0))
+ (snd-display ";xramp-channel .4 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (do ((i 0 (+ i 1)))
+ ((= i size))
+ (let ((val (envelope-interp (* i incr) '(0.0 0.0 1.0 1.0) 0.4))
+ (segval (env e)))
+ (if (or (fneq segval val)
+ (fneq (data i) val))
+ (snd-display ";xramp-channel .4 ~A of ~A: ramp: ~A, interp: ~A, env: ~A" i size (data i) val segval)))))
(undo)
(xramp-channel 1.0 -1.0 8.0)
- (let ((e (make-env '(0 1 1 -1) :length size :base 8.0)))
- (let ((data (channel->float-vector)))
- (if (or (fneq (data 0) 1.0)
- (fneq (data (- size 1)) -1.0))
- (snd-display ";xramp-channel 1 -1 8 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
- (do ((i 0 (+ i 1)))
- ((= i size))
- (let ((segval (env e)))
- (if (fneq segval (data i))
- (snd-display ";xramp-channel 1 -1 8 ~A of ~A: ramp: ~A, env: ~A" i size (data i) segval))))))
+ (let* ((e (make-env '(0 1 1 -1) :length size :base 8.0))
+ (data (channel->float-vector)))
+ (if (or (fneq (data 0) 1.0)
+ (fneq (data (- size 1)) -1.0))
+ (snd-display ";xramp-channel 1 -1 8 ~A end points: ~A ~A" size (data 0) (data (- size 1))))
+ (do ((i 0 (+ i 1)))
+ ((= i size))
+ (let ((segval (env e)))
+ (if (fneq segval (data i))
+ (snd-display ";xramp-channel 1 -1 8 ~A of ~A: ramp: ~A, env: ~A" i size (data i) segval)))))
(undo)
(close-sound ind)))
- (list 10 100 1000))
+ '(10 100 1000))
;; basic edit tree cases
(let ((ind (new-sound "test.snd")))
@@ -5054,9 +5037,9 @@ EDITS: 5
"))
(snd-display ";xramp 7: ~A" (safe-display-edits ind 0 3)))
(set! ctr 0)
- (let ((p (make-one-pole 1.0 -1.0)))
- (let ((baddy (scan-channel (lambda (y) (fneq y (* 0.5 (float-vector-ref vals (floor (- (one-pole p 1.0) 1.0)))))))))
- (if baddy (snd-display ";trouble in xramp 7: ~A" baddy))))
+ (let* ((p (make-one-pole 1.0 -1.0))
+ (baddy (scan-channel (lambda (y) (fneq y (* 0.5 (float-vector-ref vals (floor (- (one-pole p 1.0) 1.0)))))))))
+ (if baddy (snd-display ";trouble in xramp 7: ~A" baddy)))
(undo)
(delete-sample 0)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5066,9 +5049,9 @@ EDITS: 5
"))
(snd-display ";xramp 8: ~A" (safe-display-edits ind 0 3)))
(set! ctr 1)
- (let ((p (make-one-pole 1.0 -1.0)))
- (let ((baddy (scan-channel (lambda (y) (fneq y (float-vector-ref vals (floor (one-pole p 1.0))))))))
- (if baddy (snd-display ";trouble in xramp 8: ~A" baddy))))
+ (let* ((p (make-one-pole 1.0 -1.0))
+ (baddy (scan-channel (lambda (y) (fneq y (float-vector-ref vals (floor (one-pole p 1.0))))))))
+ (if baddy (snd-display ";trouble in xramp 8: ~A" baddy)))
(undo)
(delete-samples 0 2)
(if (not (string-=? (safe-display-edits ind 0 3) "
@@ -5319,21 +5302,21 @@ EDITS: 5
(float-vector->channel (make-float-vector 3 1.0) 10 8)
(if (fneq (maxamp ind 0) 1.0)
(snd-display ";float-vector->channel size mismatch maxamp: ~A" (maxamp ind 0)))
- (if (not (vequal (channel->float-vector 0 20 ind 0)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0)
(float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";float-vector->channel size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
(revert-sound ind)
(set! (samples 10 5) (make-float-vector 3 1.0))
(if (fneq (maxamp ind 0) 1.0)
(snd-display ";set samples size mismatch maxamp: ~A" (maxamp ind 0)))
- (if (not (vequal (channel->float-vector 0 20 ind 0)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0)
(float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";set samples size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
(revert-sound ind)
(insert-samples 10 8 (make-float-vector 3 1.0) ind 0)
(if (fneq (maxamp ind 0) 1.0)
(snd-display ";insert samples size mismatch maxamp: ~A" (maxamp ind 0)))
- (if (not (vequal (channel->float-vector 0 20 ind 0)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20 ind 0)
(float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";insert samples size mismatch: ~A" (channel->float-vector 0 20 ind 0)))
(close-sound ind))
@@ -5354,22 +5337,15 @@ EDITS: 5
(play "oboe.snd" :start 12000 :wait #t)
(play "oboe.snd" :start 12000 :end 15000 :wait #t)
(play :edit-position (- (edit-position) 1) :wait #t)
- (let ((old-speed (speed-control index))
- (old-style *speed-control-style*)
- (old-open (show-controls index)))
- (set! (show-controls index) #t)
- (set! (speed-control index) -2.0)
+ (let-temporarily (((speed-control index) -2.0)
+ (*speed-control-style* speed-control-as-semitone)
+ ((show-controls index) #t))
(play index :start 12345 :wait #t)
- (set! *speed-control-style* speed-control-as-semitone)
(set! (speed-control index) 0.5)
(set! *speed-control-style* speed-control-as-ratio)
- (set! (speed-control index) 0.25)
- (set! (speed-control index) old-speed)
- (set! *speed-control-style* old-style)
- (set! (show-controls index) old-open))
+ (set! (speed-control index) 0.25))
(let ((k (disk-kspace "oboe.snd")))
- (if (or (not (number? k))
- (<= k 0))
+ (if (<= k 0)
(snd-display ";disk-kspace = ~A" (disk-kspace "oboe.snd")))
(set! k (disk-kspace "/baddy/hiho"))
(if (not (= k -1))
@@ -5433,7 +5409,7 @@ EDITS: 5
(let ((data (make-graph-data)))
(if (float-vector? data)
(let ((mid (round (* .5 (length data)))))
- (if (not (= (length data) (+ 1 (- (right-sample) (left-sample)))))
+ (if (not (= (length data) (- (+ (right-sample) 1) (left-sample))))
(snd-display ";make-graph-data bounds: ~A ~A -> ~A" (left-sample) (right-sample) (length data)))
(if (fneq (data mid)
(sample (+ (left-sample) mid)))
@@ -5471,16 +5447,16 @@ EDITS: 5
(let ((tag (catch #t (lambda () (peaks "/baddy/hiho")) (lambda args (car args)))))
(if (not (eq? tag 'cant-open-file)) (snd-display ";peaks bad file: ~A" tag)))
(peaks "tmp.peaks")
- (let ((p (open-input-file "tmp.peaks")))
- (let ((line (read-line p)))
- (if (not (string=? "Snd: fft peaks" (substring line 0 14)))
- (snd-display ";peaks 1: ~A?" line))
- (set! line (read-line p))
- (set! line (read-line p))
- (if (not (member line '(#<eof> "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2"
- "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2\n")))
- (snd-display ";peaks 2: ~A?" line))
- (close-input-port p)))
+ (let* ((p (open-input-file "tmp.peaks"))
+ (line (read-line p)))
+ (if (not (string=? "Snd: fft peaks" (substring line 0 14)))
+ (snd-display ";peaks 1: ~A?" line))
+ (set! line (read-line p))
+ (set! line (read-line p))
+ (if (not (member line '(#<eof> "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2"
+ "oboe.snd, fft 512 points beginning at sample 0 (0.000 secs), Blackman2\n")))
+ (snd-display ";peaks 2: ~A?" line))
+ (close-input-port p))
(delete-file "tmp.peaks")
(peaks)
(if (and (provided? 'xm)
@@ -5507,26 +5483,27 @@ EDITS: 5
(if (read-only index) (snd-display ";read-only open-sound: ~A?" (read-only index)))
(set! (read-only index) #t)
(if (not (read-only index)) (snd-display ";set-read-only: ~A?" (read-only index)))
- (bind-key #\a 0 (lambda () (set! a-ctr 3)))
- (key (char->integer #\a) 0)
- (if (not (= a-ctr 3)) (snd-display ";bind-key: ~A?" a-ctr))
- (let ((str (with-output-to-string (lambda () (display (procedure-source (key-binding (char->integer #\a) 0)))))))
- (if (not (string=? str "(lambda () (set! a-ctr 3))"))
- (snd-display ";key-binding: ~A?" str)))
- (unbind-key (char->integer #\a) 0)
- (set! a-ctr 0)
- (key (char->integer #\a) 0)
+ (when with-gui
+ (bind-key #\a 0 (lambda () (set! a-ctr 3)))
+ (key (char->integer #\a) 0)
+ (if (not (= a-ctr 3)) (snd-display ";bind-key: ~A?" a-ctr))
+ (let ((str (with-output-to-string (lambda () (display (procedure-source (key-binding (char->integer #\a) 0)))))))
+ (if (not (string=? str "(lambda () (set! a-ctr 3))"))
+ (snd-display ";key-binding: ~A?" str)))
+ (unbind-key (char->integer #\a) 0)
+ (set! a-ctr 0)
+ (key (char->integer #\a) 0))
(do ((i 0 (+ i 1)))
((= i 5))
- (let ((psf *eps-file*))
- (if (string? psf)
- (begin
- (if (file-exists? psf) (delete-file psf))
- (set! *graph-style* i)
- (graph->ps)
- (if (file-exists? psf)
- (delete-file psf)
- (snd-display ";graph->ps: ~A?" psf))))))
+ (if (string? *eps-file*)
+ (begin
+ (if (file-exists? *eps-file*)
+ (delete-file *eps-file*))
+ (set! *graph-style* i)
+ (graph->ps)
+ (if (file-exists? *eps-file*)
+ (delete-file *eps-file*)
+ (snd-display ";graph->ps: ~A?" *eps-file*)))))
(let ((err (catch 'cannot-print
(lambda ()
(graph->ps "/bad/bad.eps"))
@@ -5620,7 +5597,7 @@ EDITS: 5
(if (not (selection-member? index)) (snd-display ";selection-member?: ~A" (selection-member? index)))
(if (not (= (region-srate r0) 22050)) (snd-display ";region-srate: ~A?" (region-srate r0)))
(if (not (= (region-chans r0) 1)) (snd-display ";region-chans: ~A?" (region-chans r0)))
- (if (not (equal? (region-home r0) (list "oboe.snd" 0 50827))) (snd-display ";region-home: ~A" (region-home r0)))
+ (if (not (equal? (region-home r0) '("oboe.snd" 0 50827))) (snd-display ";region-home: ~A" (region-home r0)))
(if (not (= (region-framples r0) 50828)) (snd-display ";region-framples: ~A?" (region-framples r0)))
(if (not (= (selection-framples) 50828)) (snd-display ";selection-framples: ~A?" (selection-framples 0)))
(if (not (= (framples sel) 50828)) (snd-display ";generic selection-framples: ~A?" (framples sel)))
@@ -5651,13 +5628,11 @@ EDITS: 5
(let ((reader-string (format #f "~A" vr)))
(if (not (string=? reader-string "#<sampler: oboe.snd[0: 0] from 0, at 0, forward>"))
(snd-display ";sampler actually got: [~S]" reader-string)))
- (let ((evr vr))
- (if (not (equal? evr vr)) (snd-display ";sampler equal? ~A ~A" vr evr)))
(catch 'break
(lambda ()
(do ((i 0 (+ i 1)))
((= i 50827))
- (if (not (= (if (odd? i) (next-sample vr) (read-sample vr)) (samps1 i) (samps2 i)))
+ (if (not (= ((if (odd? i) next-sample read-sample) vr) (samps1 i) (samps2 i)))
(begin
(snd-display ";readers disagree at ~D" i)
(throw 'break)))))
@@ -5679,8 +5654,7 @@ EDITS: 5
(if (not (string=? (substring str (- (length str) 16)) "at eof or freed>"))
(snd-display ";freed sampler: ~A [~A]?" str (substring str (- (length str) 16))))))
(let* ((reg (car (regions)))
- (chns (region-chans reg))
- (var (catch #t (lambda () (make-region-sampler reg 0 (+ chns 1))) (lambda args args))))
+ (var (catch #t (lambda () (make-region-sampler reg 0 (+ (region-chans reg) 1))) (lambda args args))))
(if (not (eq? (car var) 'no-such-channel))
(snd-display ";make-region-sampler bad chan (2): ~A ~A" var (regions)))
(let ((tag (catch #t (lambda () (make-region-sampler reg 0 0 -2)) (lambda args args))))
@@ -5736,12 +5710,12 @@ EDITS: 5
(if (or (fneq (sample 60) .25) (fneq (sample 61) .25))
(snd-display ";set-samples: ~A ~A ~A?" (sample 60) (sample 61) (sample 62))))
(set! (samples 10 3 index) (list 0.1 0.2 0.3))
- (if (not (vequal (channel->float-vector 10 3 index) (float-vector 0.1 0.2 0.3)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 3 index) (float-vector 0.1 0.2 0.3)))
(snd-display ";set-samples via list: ~A" (channel->float-vector 10 3 index)))
(revert-sound index)
(save-sound-as "temporary.snd" index)
(set! (samples 100000 20000 index) "temporary.snd")
- (if (not (vequal (channel->float-vector 110000 10) (channel->float-vector 10000 10)))
+ (if (not (mus-arrays-equal? (channel->float-vector 110000 10) (channel->float-vector 10000 10)))
(snd-display ";set samples to self: ~A ~A" (channel->float-vector 110000 10) (channel->float-vector 10000 10)))
(revert-sound index)
(delete-sample 100 index)
@@ -5927,13 +5901,13 @@ EDITS: 5
(eq? (car var) 'out-of-range)))
(snd-display ";new-sound bad chan: ~A" var)))
(set! index (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "unequal lens"))
+ (set! (sync index) 0) ; might be set by choice of graphs
(insert-silence 0 1000 index 1)
(if (not (and (= (framples index 0) 1)
(= (framples index 1) 1001)))
(snd-display ";silence 1: ~A ~A" (framples index 0) (framples index 1)))
(save-sound index)
- (if (not (and (= (framples index 0) 1001)
- (= (framples index 1) 1001)))
+ (if (not (= (framples index 0) 1001 (framples index 1)))
(snd-display ";saved silence 1: ~A ~A" (framples index 0) (framples index 1)))
(if (not (= (mus-sound-framples "fmv.snd") 1001))
(snd-display ";saved framers silence 1: ~A" (mus-sound-framples "fmv.snd")))
@@ -5989,10 +5963,8 @@ EDITS: 5
(float-vector->channel v0)
(select-all)
- (let ((old-wid *sinc-width*))
- (set! *sinc-width* 40)
- (src-selection 0.5)
- (set! *sinc-width* old-wid))
+ (let-temporarily ((*sinc-width* 40))
+ (src-selection 0.5))
(set! v0 (channel->float-vector 0 128 index 0))
(if (or (fneq (sample 20) .5) (fneq (sample 30) 0.0) (fneq (sample 17) -.1057) )
(snd-display ";src-selection: ~A?" v0))
@@ -6103,14 +6075,14 @@ EDITS: 5
(reset-controls obind)
(if (ffneq (amp-control obind) 1.0) (snd-display ";reset amp-control ~A" (amp-control obind)))
(set! (amp-control-bounds obind) (list 0.0 4.0))
- (if (not (equal? (amp-control-bounds obind) (list 0.0 4.0))) (snd-display ";amp-control-bounds: ~A" (amp-control-bounds)))
+ (if (not (equal? (amp-control-bounds obind) '(0.0 4.0))) (snd-display ";amp-control-bounds: ~A" (amp-control-bounds)))
(set! (amp-control obind) 2.0)
(if (eq? (without-errors (apply-controls obind)) 'no-such-sound) (snd-display ";apply-controls can't find oboe.snd?"))
(let ((newamp (maxamp obind)))
(if (> (abs (- (* 2.0 vol) newamp)) .05) (snd-display ";apply amp: ~A -> ~A?" vol newamp)))
(set! (amp-control-bounds obind) (list 0.0 8.0))
(set! (speed-control-bounds obind) (list 1.0 5.0))
- (if (not (equal? (speed-control-bounds obind) (list 1.0 5.0))) (snd-display ";speed-control-bounds: ~A" (speed-control-bounds)))
+ (if (not (equal? (speed-control-bounds obind) '(1.0 5.0))) (snd-display ";speed-control-bounds: ~A" (speed-control-bounds)))
(set! (speed-control obind) 0.5)
(set! (speed-control-bounds obind) (list .05 20.0))
(add-mark 1234)
@@ -6121,11 +6093,11 @@ EDITS: 5
;; within 256 which is apply's buffer size (it always flushes full buffers)
(set! (contrast-control? obind) #t)
(set! (contrast-control-bounds obind) (list 0.5 2.5))
- (if (not (equal? (contrast-control-bounds obind) (list 0.5 2.5))) (snd-display ";contrast-control-bounds: ~A" (contrast-control-bounds)))
+ (if (not (equal? (contrast-control-bounds obind) '(0.5 2.5))) (snd-display ";contrast-control-bounds: ~A" (contrast-control-bounds)))
(set! (contrast-control obind) 1.0)
(apply-controls obind)
(set! (contrast-control-bounds obind) (list 0.0 10.0))
- (if (not (equal? (contrast-control-bounds obind) (list 0.0 10.0))) (snd-display ";contrast-control-bounds (2): ~A" (contrast-control-bounds)))
+ (if (not (equal? (contrast-control-bounds obind) '(0.0 10.0))) (snd-display ";contrast-control-bounds (2): ~A" (contrast-control-bounds)))
(let ((secamp (maxamp obind))
(secdur (framples obind)))
(if (fneq secamp .989) (snd-display ";apply contrast: ~A?" secamp))
@@ -6133,10 +6105,10 @@ EDITS: 5
(undo 3 obind)
(set! (reverb-control? obind) #t)
(set! (reverb-control-scale-bounds obind) (list 0.0 1.0))
- (if (not (equal? (reverb-control-scale-bounds obind) (list 0.0 1.0)))
+ (if (not (equal? (reverb-control-scale-bounds obind) '(0.0 1.0)))
(snd-display ";reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds)))
(set! (reverb-control-length-bounds obind) (list 0.0 2.0))
- (if (not (equal? (reverb-control-length-bounds obind) (list 0.0 2.0)))
+ (if (not (equal? (reverb-control-length-bounds obind) '(0.0 2.0)))
(snd-display ";reverb-control-length-bounds: ~A" (reverb-control-length-bounds)))
(set! (reverb-control-scale obind) .2)
(let ((nowamp (maxamp obind)))
@@ -6151,7 +6123,7 @@ EDITS: 5
(undo 1 obind)
(set! (expand-control? obind) #t)
(set! (expand-control-bounds obind) (list 1.0 3.0))
- (if (not (equal? (expand-control-bounds obind) (list 1.0 3.0))) (snd-display ";expand-control-bounds: ~A" (expand-control-bounds)))
+ (if (not (equal? (expand-control-bounds obind) '(1.0 3.0))) (snd-display ";expand-control-bounds: ~A" (expand-control-bounds)))
(set! (expand-control obind) 1.5)
(apply-controls obind)
(let ((expamp (maxamp obind))
@@ -6167,7 +6139,7 @@ EDITS: 5
(let ((fltamp (maxamp obind))
(fltdur (framples obind)))
(if (> (abs (- fltamp .02)) .005) (snd-display ";apply filter scale: ~A?" fltamp))
- (if (> (- fltdur 50868) 256) (snd-display ";apply filter length: ~A?" fltdur))
+ (if (> fltdur 51124) (snd-display ";apply filter length: ~A?" fltdur))
(undo 1 obind)))
(revert-sound obind)
@@ -6277,20 +6249,20 @@ EDITS: 5
(key (char->integer #\0) 0 obind)
(key (char->integer #\0) 0 obind)
(key (char->integer #\o) 4 obind)
- (if (not (= (mark-sample m1) 1100))
+ (if (and with-gui (not (= (mark-sample m1) 1100)))
(snd-display ";mark after zeros: ~D (1100)? " (mark-sample m1))))
(set! (cursor obind) 0)
(key (char->integer #\j) 4 obind)
- (if (not (= (cursor obind) 1100)) (snd-display ";c-j to ~A" (cursor obind)))
+ (if (and with-gui (not (= (cursor obind) 1100))) (snd-display ";c-j to ~A" (cursor obind)))
(add-mark 100)
(set! (cursor obind) 0)
(key (char->integer #\u) 4 obind)
(key (char->integer #\2) 0 obind)
(key (char->integer #\j) 4 obind)
- (if (not (= (cursor obind) 1100)) (snd-display ";c-u 2 c-j ~A" (cursor obind)))
+ (if (and with-gui (not (= (cursor obind) 1100))) (snd-display ";c-u 2 c-j ~A" (cursor obind)))
(key (char->integer #\-) 4 obind)
(key (char->integer #\j) 4 obind)
- (if (not (= (cursor obind) 100)) (snd-display ";c-- c-j ~A" (cursor obind)))
+ (if (and with-gui (not (= (cursor obind) 100))) (snd-display ";c-- c-j ~A" (cursor obind)))
(revert-sound obind)
(let ((frs (framples obind)))
(make-region 0 999 obind 0)
@@ -6367,20 +6339,19 @@ EDITS: 5
(scale-sound-by 2.0)
(let ((nmx (maxamp ind1 0)))
(if (fneq (* 2 mx1) nmx) (snd-display ";scale-sound-by 2.0: ~A ~A?" mx1 nmx))
- (if (not (equal? (edit-fragment 1 ind1 0) (list "scale-channel 2.000 0 #f" "scale" 0 50828)))
+ (if (not (equal? (edit-fragment 1 ind1 0) '("scale-channel 2.000 0 #f" "scale" 0 50828)))
(snd-display ";scale-sound-by: ~A?" (edit-fragment 1 ind1 0))))
(scale-sound-to 0.5)
(let ((nmx (maxamp ind1 0)))
(if (fneq nmx 0.5) (snd-display ";scale-sound-to 0.5: ~A?" nmx))
- (if (not (equal? (edit-fragment 2 ind1 0) (list "scale-channel 1.698 0 #f" "scale" 0 50828)))
+ (if (not (equal? (edit-fragment 2 ind1 0) '("scale-channel 1.698 0 #f" "scale" 0 50828)))
(snd-display ";scale-sound-to: ~A?" (edit-fragment 2 ind1 0))))
(scale-sound-by 0.0 0 1000 ind1 0)
(let ((nmx (maxamp ind1 0)))
(if (fneq 0.5 nmx) (snd-display ";scale-sound-by 0.0: ~A ~A?" mx1 nmx))
- (if (not (equal? (edit-fragment 3 ind1 0) (list "scale-channel 0.000 0 1000" "scale" 0 1000)))
+ (if (not (equal? (edit-fragment 3 ind1 0) '("scale-channel 0.000 0 1000" "scale" 0 1000)))
(snd-display ";scale-sound-by 0.0: ~A?" (edit-fragment 3 ind1 0))))
- (let* ((v (channel->float-vector 0 1000 ind1 0))
- (pk (float-vector-peak v)))
+ (let ((pk (float-vector-peak (channel->float-vector 0 1000 ind1 0))))
(if (fneq pk 0.0) (snd-display ";scale-sound-by 0.0 [0:1000]: ~A?" pk)))
(revert-sound ind1)
(let ((oldv (channel->float-vector 12000 10 ind1 0)))
@@ -6390,7 +6361,7 @@ EDITS: 5
((= i 10))
(if (fneq (* 2.0 (oldv i)) (newv i))
(snd-display ";scale ~D: ~A ~A?" i (oldv i) (newv i)))))
- (if (not (equal? (edit-fragment 1 ind1 0) (list "scale-channel 2.000 12000 10" "scale" 12000 10)))
+ (if (not (equal? (edit-fragment 1 ind1 0) '("scale-channel 2.000 12000 10" "scale" 12000 10)))
(snd-display ";scale-sound-by 2.0 [12000:10]: ~A?" (edit-fragment 1 ind1 0))))
(revert-sound ind1)
(select-sound ind2)
@@ -6403,10 +6374,9 @@ EDITS: 5
(let ((nmx (max (maxamp ind2 0) (maxamp ind2 1))))
(if (fneq nmx 0.5) (snd-display ";2 scale-sound-to 0.5: ~A (~A)?" nmx (maxamp ind2))))
(scale-sound-by 0.0 0 1000 ind2 1)
- (if (not (equal? (edit-fragment 3 ind2 1) (list "scale-channel 0.000 0 1000" "scale" 0 1000)))
+ (if (not (equal? (edit-fragment 3 ind2 1) '("scale-channel 0.000 0 1000" "scale" 0 1000)))
(snd-display ";2:1 scale-sound-by 0.0: ~A?" (edit-fragment 3 ind2 1)))
- (let* ((v (channel->float-vector 0 1000 ind2 1))
- (pk (float-vector-peak v)))
+ (let ((pk (float-vector-peak (channel->float-vector 0 1000 ind2 1))))
(if (fneq pk 0.0) (snd-display ";2:1 scale-sound-by 0.0 [0:1000]: ~A?" pk)))
(revert-sound ind2)
(let ((oldv (channel->float-vector 12000 10 ind2 0)))
@@ -6451,7 +6421,7 @@ EDITS: 5
(update-transform-graph ind 0)
(when with-motif
(let ((val (transform-framples ind 0)))
- (if (or (not (list? val))
+ (if (or (not (pair? val))
(fneq (car val) 1.0)
(not (= (caddr val) 256)))
(snd-display ";transform-framples: ~A (~A)" val (transform-size ind 0)))))
@@ -6483,12 +6453,12 @@ EDITS: 5
(if (not (feql '(0.0 0.0 1.0 1.0) (filter-control-envelope ind)))
(snd-display ";set filter-control-envelope: ~A?" (filter-control-envelope ind)))
(set! (filter-control-order ind) 20)
- (if (not (vequal (filter-control-coeffs ind)
+ (if (not (mus-arrays-equal? (filter-control-coeffs ind)
(float-vector -0.007 0.010 -0.025 0.029 -0.050 0.055 -0.096 0.109 -0.268 0.241
0.241 -0.268 0.109 -0.096 0.055 -0.050 0.029 -0.025 0.010 -0.007)))
(snd-display ";highpass coeffs: ~A" (filter-control-coeffs ind)))
(set! (filter-control-envelope ind) '(0 1 1 0))
- (if (not (vequal (filter-control-coeffs ind)
+ (if (not (mus-arrays-equal? (filter-control-coeffs ind)
(float-vector 0.003 0.002 0.004 0.002 0.007 0.003 0.014 0.012 0.059 0.394
0.394 0.059 0.012 0.014 0.003 0.007 0.002 0.004 0.002 0.003)))
(snd-display ";lowpass coeffs: ~A" (filter-control-coeffs ind)))
@@ -6497,7 +6467,7 @@ EDITS: 5
(let* ((obind (open-sound "4.aiff"))
(amps (maxamp obind #t))
(times (maxamp-position obind #t)))
- (if (not (equal? times (list 810071 810071 810071 810071)))
+ (if (not (equal? times '(810071 810071 810071 810071)))
(snd-display ";4.aiff times: ~A" times))
(if (< (window-width) 600)
(set! (window-width) 600))
@@ -6624,7 +6594,7 @@ EDITS: 5
(test-orig (lambda (snd) (map-channel (lambda (n) (* n 2.0)) 12005 10)) (lambda (snd) (map-channel (lambda (n) (* n 0.5)) 12005 10)) 'map-channel ind1)
(test-orig (lambda (snd)
(define m1
- (let ((vect (make-float-vector 2 0.0)))
+ (let ((vect (make-float-vector 2)))
(lambda (y)
(float-vector-set! vect 0 (float-vector-set! vect 1 (* y 2)))
vect)))
@@ -6661,10 +6631,10 @@ EDITS: 5
(convolve-with "fmv3.snd" 1.0 ind1)
(convolve-files "fmv4.snd" "fmv3.snd" 1.0 "fmv5.snd")
(let ((v2 (channel->float-vector 12000 10 ind1 0)))
- (if (not (vequal1 v1 v2))
+ (if (not (mus-arrays-equal?1 v1 v2))
(snd-display ";~A (orig: 0) ~A ~A" 'convolve-with v1 v2))
(file->array "fmv5.snd" 0 12000 10 v2)
- (if (not (vequal1 v1 v2))
+ (if (not (mus-arrays-equal?1 v1 v2))
(snd-display ";convolve-files: (orig: 0) ~A ~A" v1 v2)))
(delete-file "fmv3.snd")
(delete-file "fmv5.snd"))
@@ -6675,7 +6645,7 @@ EDITS: 5
(delete-file "fmv5.snd")
(scale-to .25 ind1)
(set! (y-bounds ind1) ())
- (if (not (equal? (y-bounds ind1) (list -.25 .25)))
+ (if (and with-gui (not (equal? (y-bounds ind1) '(-.25 .25))))
(snd-display ";y-bounds (): ~A?" (y-bounds ind1)))
(revert-sound ind1)
@@ -6687,10 +6657,10 @@ EDITS: 5
(convolve-with "fmv3.snd" 1.0 ind1)
(convolve-files "fmv4.snd" "fmv3.snd" 1.0 "fmv5.snd")
(let ((v2 (channel->float-vector 12005 10 ind1 0)))
- (if (not (vequal1 v1 v2))
+ (if (not (mus-arrays-equal?1 v1 v2))
(snd-display ";~A (orig: 2) ~A ~A" 'convolve-with v1 v2))
(file->array "fmv5.snd" 0 12005 10 v2)
- (if (not (vequal1 v1 v2))
+ (if (not (mus-arrays-equal?1 v1 v2))
(snd-display ";convolve-files: (orig: 2) ~A ~A" v1 v2)))
(delete-file "fmv3.snd")
(delete-file "fmv4.snd")
@@ -6708,7 +6678,7 @@ EDITS: 5
(let ((data (channel->float-vector 12000 10 ind1 0)))
(convolve-with "pistol.snd" (maxamp ind1 0 0) ind1 0 0)
(let ((new-data (channel->float-vector 12000 10 ind1 0)))
- (if (not (vequal1 data new-data))
+ (if (not (mus-arrays-equal?1 data new-data))
(snd-display ";convolve-selection-with: ~A ~A?" data new-data))))
(revert-sound ind1)
(make-selection 1000 2000 ind1)
@@ -6726,7 +6696,7 @@ EDITS: 5
(close-sound ind1))
(let* ((ind (open-sound "2.snd"))
(reg (make-region 0 100 ind #t)))
- (if (not (equal? (region-home reg) (list "2.snd" 0 100)))
+ (if (not (equal? (region-home reg) '("2.snd" 0 100)))
(snd-display ";make + region-home: ~A" (region-home reg)))
(if (not (= (region-chans reg) 2))
(snd-display ";make-region chan #t: ~A" (region-chans reg)))
@@ -6738,14 +6708,14 @@ EDITS: 5
(swap-channels ind1)
(let ((v2 (channel->float-vector 12000 10 ind1 0))
(v3 (channel->float-vector 12000 10 ind1 1)))
- (if (or (vequal v0 v2)
- (vequal v1 v3))
+ (if (or (mus-arrays-equal? v0 v2)
+ (mus-arrays-equal? v1 v3))
(snd-display ";swap-channels 0: no change! ~A ~A ~A ~A" v0 v2 v1 v3)))
(swap-channels ind1)
(let ((v2 (channel->float-vector 12000 10 ind1 0))
(v3 (channel->float-vector 12000 10 ind1 1)))
- (if (not (and (vequal v0 v2)
- (vequal v1 v3)))
+ (if (not (and (mus-arrays-equal? v0 v2)
+ (mus-arrays-equal? v1 v3)))
(snd-display ";swap-channels 1: ~A ~A ~A ~A" v0 v2 v1 v3))))
;; as long as we're here...
(set! (sync ind1) 0)
@@ -6755,7 +6725,7 @@ EDITS: 5
(= (cursor ind1 1) 200)))
(snd-display ";cursor: ~A ~A?" (cursor ind1 0) (cursor ind1 1)))
(set! (sync ind1) 1)
- (scale-by (list .5 .25) ind1)
+ (scale-by '(.5 .25) ind1)
(scale-by (float-vector 2.0 4.0) ind1)
(revert-sound ind1)
(let ((amps (maxamp ind1 #t)))
@@ -6899,11 +6869,11 @@ EDITS: 5
(snd-display ";save-sound-as (edpos 1)(2): ~A ~A?" (mus-sound-framples "fmv.snd") (framples ind1 0 1)))
(let ((ind2 (open-sound "fmv.snd"))
(ind3 (open-sound "fmv1.snd")))
- (if (not (vequal (channel->float-vector 12000 10 ind1 0 0) (channel->float-vector 12000 10 ind2 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 12000 10 ind1 0 0) (channel->float-vector 12000 10 ind2 0)))
(snd-display ";save-sound-as (edpos 3): ~A ~A?" (channel->float-vector 12000 10 ind1 0 0) (channel->float-vector 12000 10 ind2 0)))
- (if (not (vequal (channel->float-vector 12000 10 ind1 0 1) (channel->float-vector 12000 10 ind3 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 12000 10 ind1 0 1) (channel->float-vector 12000 10 ind3 0)))
(snd-display ";save-sound-as (edpos 4): ~A ~A?" (channel->float-vector 12000 10 ind1 0 1) (channel->float-vector 12000 10 ind3 0)))
- (if (vequal (channel->float-vector 12000 10 ind2 0) (channel->float-vector 12000 10 ind3 0))
+ (if (mus-arrays-equal? (channel->float-vector 12000 10 ind2 0) (channel->float-vector 12000 10 ind3 0))
(snd-display ";save-sound-as (edpos 5): ~A ~A?" (channel->float-vector 12000 10 ind2 0) (channel->float-vector 12000 10 ind3 0)))
(select-sound ind3)
(set! (comment) "hiho")
@@ -6949,8 +6919,7 @@ EDITS: 5
(set! (cursor) 2000)
(let ((here (cursor)))
(play :start (cursor))
- (if (not (and (= here 2000)
- (= (cursor) 2000)))
+ (if (not (= here 2000 (cursor)))
(snd-display ";with-tracking-cursor set to :track-and-return: start: ~A, end: ~A" here (cursor))))
(set! (zoom-focus-style) zoom-focus-middle)
@@ -7205,7 +7174,7 @@ EDITS: 5
((= j chns))
(let ((vi (channel->float-vector 0 len index j)))
(if (= j i)
- (if (not (vequal vi val))
+ (if (not (mus-arrays-equal? vi val))
(snd-display ";chan func: ~A ~A" vi val))
(if (scan-channel (lambda (n) (> (abs n) .001)) 0 len index j)
(snd-display ";chan func leaks? ~A ~A: ~A" i j (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
@@ -7220,7 +7189,7 @@ EDITS: 5
((= j chns))
(let ((vi (channel->float-vector 0 len index j)))
(if (= j i)
- (if (not (vequal vi val))
+ (if (not (mus-arrays-equal? vi val))
(snd-display ";ed chan func: ~A ~A" vi val))
(if (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j)
(snd-display ";ed chan func leaks? ~A ~A ~A: ~A" i j ed (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
@@ -7242,7 +7211,7 @@ EDITS: 5
((= j chns))
(let ((vi (channel->float-vector 0 len index j)))
(if (= j i)
- (if (not (vequal vi val))
+ (if (not (mus-arrays-equal? vi val))
(snd-display ";chan func n: ~A ~A" vi val))
(if (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j)
(snd-display ";dur chan func leaks? ~A ~A: ~A" i j (scan-channel (lambda (n) (> (abs n) 0.001)) 0 len index j))))))
@@ -7388,7 +7357,7 @@ EDITS: 5
(catch #t
(lambda ()
(for-each (lambda (n data)
- (if (not (vequal data (region->float-vector n 0 10)))
+ (if (not (mus-arrays-equal? data (region->float-vector n 0 10)))
(snd-display ";region after save ~A: ~A ~A" n data (region->float-vector n 0 10))))
(regions)
regdata))
@@ -7396,7 +7365,7 @@ EDITS: 5
(set! index (find-sound "fmv.snd"))
(if (not (equal? (maxamp index #t) old-max))
(snd-display ";maxes: ~A ~A" (maxamp index #t) old-max))
- (if (not (equal? (edits index) (list 275 0)))
+ (if (not (member (edits index) '((275 0) (276 0))))
(snd-display ";saved channel edits: ~A" (edits index)))
(do ((i 0 (+ i 1)))
@@ -7417,49 +7386,47 @@ EDITS: 5
))
(let ((index (new-sound "fmv.snd" 2 22050 mus-ldouble mus-next "channel tests"))
- (v (make-float-vector 10))
- (sw *sinc-width*))
- (set! *sinc-width* 10)
- (set! (v 0) 1.0)
- (float-vector->channel v 0 10 index 0)
- (src-channel 0.5 0 10 index 0)
- (let ((v (make-float-vector 10))
- (s (make-src :srate 0.5
- :input (let ((val 1.0))
- (lambda (dir)
- (let ((rtn val))
- (set! val 0.0)
- rtn))))))
- (set! (v 0) (src s))
- (do ((i 1 (+ i 1)))
- ((= i 10))
- (set! (v i) (src s)))
- (if (not (vequal v (channel->float-vector 0 10 index 0)))
- (snd-display ";src-channel: ~A ~A" v (channel->float-vector 0 10 index 0)))
- (if (not (vequal (make-float-vector 10) (channel->float-vector 0 10 index 1)))
- (snd-display ";src-channel leaks: ~A" (channel->float-vector 0 10 index 1))))
- (let ((tag (catch #t (lambda () (src-channel 120000.0)) (lambda args args))))
- (if (not (eq? (car tag) 'mus-error)) (snd-display ";src-channel crazy srate: ~A" tag)))
- (let ((tag (catch #t (lambda () (filter-sound (make-snd->sample))) (lambda args args))))
- (if (not (eq? (car tag) 'mus-error)) (snd-display ";filter-sound + un-run gen: ~A" tag)))
- (revert-sound index)
- (float-vector->channel v 0 10 index 1)
- (float-vector->channel v 10 10 index 1)
- (src-channel (make-env :envelope '(1 1 2 2) :length 21) 0 20 index 1)
- (if (not (vequal (channel->float-vector 0 10 index 1) (float-vector 1.000 -0.000 -0.048 0.068 -0.059 0.022 0.030 -0.100 0.273 0.606)))
- (snd-display ";src-channel env: ~A" (channel->float-vector 0 10 index 1)))
- (if (not (vequal (make-float-vector 10) (channel->float-vector 0 10 index 0)))
- (snd-display ";src-channel env leaks: ~A" (channel->float-vector 0 10 index 0)))
- (revert-sound index)
- (float-vector->channel v 0 10 index 1)
- (float-vector->channel v 10 10 index 1)
- (src-channel '(1 1 2 2) 0 20 index 1) ; end is off above -- should be 19 I think
- (if (not (vequal (channel->float-vector 0 10 index 1) (float-vector 1.000 -0.000 -0.051 0.069 -0.056 0.015 0.042 -0.117 0.320 0.568)))
- (snd-display ";src-channel lst: ~A" (channel->float-vector 0 10 index 1)))
- (if (not (vequal (make-float-vector 10) (channel->float-vector 0 10 index 0)))
- (snd-display ";src-channel lst leaks: ~A" (channel->float-vector 0 10 index 0)))
- (set! *sinc-width* sw)
- (close-sound index))
+ (v (make-float-vector 10)))
+ (let-temporarily ((*sinc-width* 10))
+ (set! (v 0) 1.0)
+ (float-vector->channel v 0 10 index 0)
+ (src-channel 0.5 0 10 index 0)
+ (let ((v (make-float-vector 10))
+ (s (make-src :srate 0.5
+ :input (let ((val 1.0))
+ (lambda (dir)
+ (let ((rtn val))
+ (set! val 0.0)
+ rtn))))))
+ (set! (v 0) (src s))
+ (do ((i 1 (+ i 1)))
+ ((= i 10))
+ (set! (v i) (src s)))
+ (if (not (mus-arrays-equal? v (channel->float-vector 0 10 index 0)))
+ (snd-display ";src-channel: ~A ~A" v (channel->float-vector 0 10 index 0)))
+ (if (not (mus-arrays-equal? (make-float-vector 10) (channel->float-vector 0 10 index 1)))
+ (snd-display ";src-channel leaks: ~A" (channel->float-vector 0 10 index 1))))
+ (let ((tag (catch #t (lambda () (src-channel 120000.0)) (lambda args args))))
+ (if (not (eq? (car tag) 'mus-error)) (snd-display ";src-channel crazy srate: ~A" tag)))
+ (let ((tag (catch #t (lambda () (filter-sound (make-snd->sample))) (lambda args args))))
+ (if (not (eq? (car tag) 'mus-error)) (snd-display ";filter-sound + un-run gen: ~A" tag)))
+ (revert-sound index)
+ (float-vector->channel v 0 10 index 1)
+ (float-vector->channel v 10 10 index 1)
+ (src-channel (make-env :envelope '(1 1 2 2) :length 21) 0 20 index 1)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 index 1) (float-vector 1.000 -0.000 -0.048 0.068 -0.059 0.022 0.030 -0.100 0.273 0.606)))
+ (snd-display ";src-channel env: ~A" (channel->float-vector 0 10 index 1)))
+ (if (not (mus-arrays-equal? (make-float-vector 10) (channel->float-vector 0 10 index 0)))
+ (snd-display ";src-channel env leaks: ~A" (channel->float-vector 0 10 index 0)))
+ (revert-sound index)
+ (float-vector->channel v 0 10 index 1)
+ (float-vector->channel v 10 10 index 1)
+ (src-channel '(1 1 2 2) 0 20 index 1) ; end is off above -- should be 19 I think
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 index 1) (float-vector 1.000 -0.000 -0.051 0.069 -0.056 0.015 0.042 -0.117 0.320 0.568)))
+ (snd-display ";src-channel lst: ~A" (channel->float-vector 0 10 index 1)))
+ (if (not (mus-arrays-equal? (make-float-vector 10) (channel->float-vector 0 10 index 0)))
+ (snd-display ";src-channel lst leaks: ~A" (channel->float-vector 0 10 index 0)))
+ (close-sound index)))
(let ((ind (new-sound :size 100)))
(for-each
@@ -7484,7 +7451,7 @@ EDITS: 5
(if (or (> sum .01) ; depends on sinc-width I think
(> mx .002))
(snd-display ";src-channel ~A: diff: ~A ~A~%" sr sum mx))))))
- (list 0.5 0.75 1.0 1.5 2.0))
+ '(0.5 0.75 1.0 1.5 2.0))
(close-sound ind))
(set! *max-regions* (max *max-regions* 8))
@@ -7494,28 +7461,28 @@ EDITS: 5
(scale-sound-by 2.0)
(play rid0 :wait #t)
(let ((nv (region2float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display ";deferred region after scaling:~% ~A~% ~A" rid0-data nv)))
+ (if (not (mus-arrays-equal? rid0-data nv)) (snd-display ";deferred region after scaling:~% ~A~% ~A" rid0-data nv)))
(let ((nv (region-to-float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display ";deferred region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
+ (if (not (mus-arrays-equal? rid0-data nv)) (snd-display ";deferred region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
(undo)
(scale-by 4.0)
(play rid0 :wait #t)
(let ((nv (region2float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display ";file region after scaling:~% ~A~% ~A" rid0-data nv)))
+ (if (not (mus-arrays-equal? rid0-data nv)) (snd-display ";file region after scaling:~% ~A~% ~A" rid0-data nv)))
(let ((nv (region-to-float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display ";file region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
+ (if (not (mus-arrays-equal? rid0-data nv)) (snd-display ";file region after scaling (rs):~% ~A~% ~A" rid0-data nv)))
(let* ((rid1 (make-region 2000 2020 ind 0))
(rid1-data (region2float-vector rid1 0 20)))
(scale-to .5)
(let ((nv (region2float-vector rid1 0 20)))
- (if (not (vequal rid1-data nv)) (snd-display ";deferred region after scale-to:~% ~A~% ~A" rid1-data nv)))
+ (if (not (mus-arrays-equal? rid1-data nv)) (snd-display ";deferred region after scale-to:~% ~A~% ~A" rid1-data nv)))
(close-sound ind)
(play rid0 :wait #t)
(play rid1 :wait #t)
(let ((nv (region2float-vector rid1 0 20)))
- (if (not (vequal rid1-data nv)) (snd-display ";deferred region after close:~% ~A~% ~A" rid1-data nv)))
+ (if (not (mus-arrays-equal? rid1-data nv)) (snd-display ";deferred region after close:~% ~A~% ~A" rid1-data nv)))
(let ((nv (region2float-vector rid0 0 20)))
- (if (not (vequal rid0-data nv)) (snd-display ";file region after close:~% ~A~% ~A" rid0-data nv))))
+ (if (not (mus-arrays-equal? rid0-data nv)) (snd-display ";file region after close:~% ~A~% ~A" rid0-data nv))))
(for-each
(lambda (s1 L1 s2 L2)
@@ -7533,27 +7500,27 @@ EDITS: 5
(if (not (= (region-chans rid2) 2)) (snd-display ";region-chans of sync'd sound: ~A?" (region-chans rid2)))
(swap-channels ind 0 ind 1)
(let ((nv (region2float-vector rid2 0 L1)))
- (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
+ (if (not (mus-arrays-equal? rid20-data nv)) (snd-display ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
(let ((nv (region-to-float-vector rid2 0 L1)))
- (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
+ (if (not (mus-arrays-equal? rid20-data nv)) (snd-display ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
(let ((nv (region2float-vector rid2 1 L2)))
- (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
+ (if (not (mus-arrays-equal? rid21-data nv)) (snd-display ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
(let ((nv (region-to-float-vector rid2 1 L2)))
- (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
+ (if (not (mus-arrays-equal? rid21-data nv)) (snd-display ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
(close-sound ind)
(let ((nv (region2float-vector rid2 0 L1)))
- (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
+ (if (not (mus-arrays-equal? rid20-data nv)) (snd-display ";deferred region after scaling (20):~% ~A~% ~A" rid20-data nv)))
(let ((nv (region-to-float-vector rid2 0 L1)))
- (if (not (vequal rid20-data nv)) (snd-display ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
+ (if (not (mus-arrays-equal? rid20-data nv)) (snd-display ";deferred region after scaling (20 rs):~% ~A~% ~A" rid20-data nv)))
(let ((nv (region2float-vector rid2 1 L2)))
- (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
+ (if (not (mus-arrays-equal? rid21-data nv)) (snd-display ";deferred region after scaling (21):~% ~A~% ~A" rid21-data nv)))
(let ((nv (region-to-float-vector rid2 1 L2)))
- (if (not (vequal rid21-data nv)) (snd-display ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
+ (if (not (mus-arrays-equal? rid21-data nv)) (snd-display ";deferred region after scaling (21 rs):~% ~A~% ~A" rid21-data nv)))
))
- (list 2000 2000 2000 0 2000 0 2000)
- (list 20 10 20 20 20 10 20)
- (list 2000 2000 2000 2000 0 2000 0)
- (list 20 20 10 20 20 20 10)))
+ '(2000 2000 2000 0 2000 0 2000)
+ '(20 10 20 20 20 10 20)
+ '(2000 2000 2000 2000 0 2000 0)
+ '(20 20 10 20 20 20 10)))
(let ((ind (open-sound "obtest.snd")))
(set! (read-only ind) #t)
@@ -7563,7 +7530,7 @@ EDITS: 5
(save-sound ind))
(lambda args args))))
(if (sound? val) (snd-display ";save-sound read-only: ~A" val))
- (if (not (equal? (edits ind) (list 1 0))) (snd-display ";read-only ignored? ~A" (edits ind))))
+ (if (not (equal? (edits ind) '(1 0))) (snd-display ";read-only ignored? ~A" (edits ind))))
(set! (read-only ind) #f)
(revert-sound ind)
(let ((tag (catch #t
@@ -7581,12 +7548,12 @@ EDITS: 5
(let ((ns (new-sound)))
(unselect-all)
- (let ((v (make-float-vector 1000)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x .001)))
- ((= i 1000))
- (set! (v i) x))
- (float-vector->channel v 0 1000 ns 0))
+ (do ((v (make-float-vector 1000))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x .001)))
+ ((= i 1000)
+ (float-vector->channel v 0 1000 ns 0))
+ (set! (v i) x))
(set! (selection-member? ns 0) #t)
(set! (selection-position ns 0) 200)
(set! (selection-framples ns 0) 300)
@@ -7616,12 +7583,12 @@ EDITS: 5
(close-sound ns))
(let ((ns (new-sound)))
- (let ((v (make-float-vector 1000)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x .001)))
- ((= i 1000))
- (set! (v i) x))
- (float-vector->channel v 0 1000 ns 0))
+ (do ((v (make-float-vector 1000))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x .001)))
+ ((= i 1000)
+ (float-vector->channel v 0 1000 ns 0))
+ (set! (v i) x))
(delete-samples-and-smooth 200 300 ns 0)
(if (not (= (framples ns 0) 700))
(snd-display ";delete-samples-and-smooth framples: ~A" (framples ns 0)))
@@ -7647,54 +7614,48 @@ EDITS: 5
(snd-display ";delete-samples-and-smooth max diff: ~A" maxdiff)))
(close-sound ns))
- (let ((old-beg *initial-beg*)
- (old-dur *initial-dur*)
- (old-show *show-full-duration*)
- (old-hook (hook-functions initial-graph-hook)))
- (set! (hook-functions initial-graph-hook) ())
- (set! *show-full-duration* #t)
- (let ((ns (open-sound "1.snd")))
- (let ((ls (left-sample ns 0))
- (rs (right-sample ns 0))
- (fr (framples ns 0)))
- (when (and with-gui
- (not (equal? (list fr ls rs) '(220501 0 220501))))
- (snd-display ";show-full-duration 1: ~A" (list fr ls rs)))
- (close-sound ns)))
- (set! *show-full-duration* #t)
- (set! *initial-beg* 0.0)
- (set! *initial-dur* 0.2)
- (let ((ns (open-sound "1.snd")))
- (let ((ls (left-sample ns 0))
- (rs (right-sample ns 0))
- (fr (framples ns 0)))
- (when (and with-gui
- (not (equal? (list fr ls rs) '(220501 0 220501))))
- (snd-display ";show-full-duration 2: ~A" (list fr ls rs)))
- (close-sound ns)))
- (set! *show-full-duration* #f)
- (set! *initial-beg* 0.0)
- (set! *initial-dur* 0.2)
- (let ((ns (open-sound "1.snd")))
- (let ((ls (left-sample ns 0))
- (rs (right-sample ns 0))
- (fr (framples ns 0)))
- (if (not (equal? (list fr ls rs) '(220501 0 4410)))
- (snd-display ";show-full-duration 3: ~A" (list fr ls rs)))
- (close-sound ns)))
- (set! *initial-beg* 2.0)
- (set! *initial-dur* 1.0)
- (let ((ns (open-sound "1.snd")))
- (let ((ls (left-sample ns 0))
- (rs (right-sample ns 0))
- (fr (framples ns 0)))
- (if (not (equal? (list fr ls rs) '(220501 44100 66150)))
- (snd-display ";show-full-duration 4: ~A" (list fr ls rs)))
- (close-sound ns)))
- (set! *initial-beg* old-beg)
- (set! *initial-dur* old-dur)
- (set! *show-full-duration* old-show)
- (set! (hook-functions initial-graph-hook) old-hook))
+ (let ((old-hook (hook-functions initial-graph-hook)))
+ (let-temporarily ((*show-full-duration* #t))
+ (set! (hook-functions initial-graph-hook) ())
+ (let ((ns (open-sound "1.snd")))
+ (let ((ls (left-sample ns 0))
+ (rs (right-sample ns 0))
+ (fr (framples ns 0)))
+ (when (and with-gui
+ (not (equal? (list fr ls rs) '(220501 0 220501))))
+ (snd-display ";show-full-duration 1: ~A" (list fr ls rs)))
+ (close-sound ns)))
+ (set! *show-full-duration* #t)
+ (let-temporarily ((*initial-beg* 0.0)
+ (*initial-dur* 0.2))
+ (let ((ns (open-sound "1.snd")))
+ (let ((ls (left-sample ns 0))
+ (rs (right-sample ns 0))
+ (fr (framples ns 0)))
+ (when (and with-gui
+ (not (equal? (list fr ls rs) '(220501 0 220501))))
+ (snd-display ";show-full-duration 2: ~A" (list fr ls rs)))
+ (close-sound ns)))
+ (set! *show-full-duration* #f)
+ (set! *initial-beg* 0.0)
+ (set! *initial-dur* 0.2)
+ (let ((ns (open-sound "1.snd")))
+ (let ((ls (left-sample ns 0))
+ (rs (right-sample ns 0))
+ (fr (framples ns 0)))
+ (if (not (equal? (list fr ls rs) '(220501 0 4410)))
+ (snd-display ";show-full-duration 3: ~A" (list fr ls rs)))
+ (close-sound ns)))
+ (set! *initial-beg* 2.0)
+ (set! *initial-dur* 1.0)
+ (let ((ns (open-sound "1.snd")))
+ (let ((ls (left-sample ns 0))
+ (rs (right-sample ns 0))
+ (fr (framples ns 0)))
+ (if (not (equal? (list fr ls rs) '(220501 44100 66150)))
+ (snd-display ";show-full-duration 4: ~A" (list fr ls rs)))
+ (close-sound ns))))
+ (set! (hook-functions initial-graph-hook) old-hook)))
(set! *show-full-range* #t)
(let ((ns (open-sound "1a.snd")))
@@ -7719,8 +7680,7 @@ EDITS: 5
(close-sound ns))
(set! *show-full-range* #f)
- (let ((old-sync *sync-style*))
- (set! *sync-style* sync-none)
+ (let-temporarily ((*sync-style* sync-none))
(let ((ns (open-sound "2.snd")))
(if (not (= (sync ns) 0))
(snd-display ";sync-none open: ~A" (sync ns)))
@@ -7732,8 +7692,7 @@ EDITS: 5
(not (= (sync ns) 1)))
(snd-display ";sync-by-sound open: ~A" (list (sync ns) (sync ns1))))
(close-sound ns1))
- (close-sound ns))
- (set! *sync-style* old-sync))
+ (close-sound ns)))
(let ((ind (view-sound "obtest.snd")))
(delete-samples 0 1000 ind 0)
@@ -7741,7 +7700,7 @@ EDITS: 5
(lambda () (save-sound ind))
(lambda args args))))
(if (integer? tag) (snd-display ";save-viewed-sound: ~A" tag))
- (if (not (equal? (edits ind) (list 1 0))) (snd-display ";view read-only ignored? ~A" (edits ind))))
+ (if (not (equal? (edits ind) '(1 0))) (snd-display ";view read-only ignored? ~A" (edits ind))))
(close-sound ind))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
@@ -7749,10 +7708,8 @@ EDITS: 5
(map-channel (lambda (y) 0.5))
(env-sound '(0 0 1 1 2 0))
(fp 1.0 0.3 20)
- (let ((old-curse *with-tracking-cursor*))
- (set! *with-tracking-cursor* #t)
- (play :wait #t)
- (set! *with-tracking-cursor* old-curse))
+ (let-temporarily ((*with-tracking-cursor* #t))
+ (play :wait #t))
(close-sound ind))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
(for-each
@@ -7768,10 +7725,10 @@ EDITS: 5
(let ((v0 (make-float-vector len))
(v1 (samples 0 len ind 0)))
(outa->fv v0 (env e))
- (if (not (vequal v0 v1))
+ (if (not (mus-arrays-equal? v0 v1))
(snd-display "~%;trouble in reverse read ~A ~A" v0 v1))))
(revert-sound))
- (list 150 1500 150000))
+ '(150 1500 150000))
(close-sound ind))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
(insert-silence 0 1000)
@@ -7819,7 +7776,7 @@ EDITS: 5
(let ((len (framples)))
(let ((v0 (samples 0 len ind 0 (- (edit-position ind 0) 2)))
(v1 (samples 0 len ind 0)))
- (if (not (vequal v0 v1))
+ (if (not (mus-arrays-equal? v0 v1))
(snd-display "~%;trouble in reverse read ~A ~A" v0 v1))))
(set! (edit-position ind 0) edpos)))
(close-sound ind))
@@ -7844,10 +7801,10 @@ EDITS: 5
(if (fneq (sample) samp)
(snd-display ";sample no args: ~A ~A" (sample) samp)))
(set! val (my-scan-channel (lambda (y) (> y .1))))
- (if (not (equal? val (list #t 4423)))
+ (if (not (equal? val '(#t 4423)))
(snd-display ";my-scan-chan: ~A" val))
(set! val (scan-again))
- (if (not (equal? val (list #t 4463)))
+ (if (not (equal? val '(#t 4463)))
(snd-display ";scan-again: ~A" val))
(set! (cursor) 1000)
(set! (sample) .5)
@@ -7862,7 +7819,7 @@ EDITS: 5
(let ((newsnd (selection->new)))
(if (not (sound? newsnd)) (snd-display ";selection->new -> ~A" newsnd))
(if (not (= (framples newsnd 0) 1000)) (snd-display ";selection->new framples: ~A" (framples newsnd 0)))
- (if (not (equal? (edits ind 0) (list 0 0))) (snd-display ";selection->new edited original? ~A" (edits ind 0)))
+ (if (not (equal? (edits ind 0) '(0 0))) (snd-display ";selection->new edited original? ~A" (edits ind 0)))
(let ((newfile (file-name newsnd)))
(close-sound newsnd)
(delete-file newfile)
@@ -7871,7 +7828,7 @@ EDITS: 5
(let ((newsnd (cut-selection->new)))
(if (not (sound? newsnd)) (snd-display ";cut-selection->new -> ~A" newsnd))
(if (not (= (framples newsnd 0) 1000)) (snd-display ";cut-selection->new framples: ~A" (framples newsnd 0)))
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";cut-selection->new did not edit original? ~A" (edits ind 0)))
+ (if (not (equal? (edits ind 0) '(1 0))) (snd-display ";cut-selection->new did not edit original? ~A" (edits ind 0)))
(if (not (= (framples ind 0) (- (framples ind 0 0) 1000)))
(snd-display ";cut-selection->new cut: ~A ~A" (framples ind 0) (- (framples ind 0 0) 1000)))
(undo 1 ind 0)
@@ -7890,19 +7847,19 @@ EDITS: 5
(let ((m1 (add-mark 1000))
(m2 (add-mark 12000)))
(trim-front)
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";time-front did not edit original? ~A" (edits ind 0)))
+ (if (not (equal? (edits ind 0) '(1 0))) (snd-display ";time-front did not edit original? ~A" (edits ind 0)))
(if (not (= (framples ind 0) (- (framples ind 0 0) 1000)))
(snd-display ";trim-front: ~A ~A" (framples ind 0) (- (framples ind 0 0) 1000)))
(if (not (= (mark-sample m2) 11000)) (snd-display ";trim-front m2: ~A" (mark-sample m2)))
(undo 1 ind 0)
(trim-back)
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";time-back did not edit original? ~A" (edits ind 0)))
+ (if (not (equal? (edits ind 0) '(1 0))) (snd-display ";time-back did not edit original? ~A" (edits ind 0)))
(if (not (= (framples ind 0) 12001)) (snd-display ";trim-back: ~A" (framples ind 0)))
(if (not (= (mark-sample m1) 1000)) (snd-display ";trim-back m1: ~A" (mark-sample m1))))
(undo 1 ind 0)
(add-mark 22000)
(crop)
- (if (not (equal? (edits ind 0) (list 1 0))) (snd-display ";crop did not edit original? ~A" (edits ind 0)))
+ (if (not (equal? (edits ind 0) '(1 0))) (snd-display ";crop did not edit original? ~A" (edits ind 0)))
(if (not (= (framples ind 0) 21001)) (snd-display ";crop: ~A" (framples ind 0)))
(undo 1 ind 0)
(close-sound ind)))
@@ -7947,7 +7904,7 @@ EDITS: 5
(do ((i 0 (+ i 1)))
((= i 20))
(set! (data i) (hilbert-transform hlb (if (= i 0) 1.0 0.0))))
- (if (not (vequal data (float-vector 0.0 -0.010 0.0 -0.046 0.0 -0.152 0.0 -0.614 0.0 0.614 0.0 0.152 0.0 0.046 0.0 0.010 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 -0.010 0.0 -0.046 0.0 -0.152 0.0 -0.614 0.0 0.614 0.0 0.152 0.0 0.046 0.0 0.010 0.0 0.0 0.0 0.0)))
(snd-display ";hilbert-transform 8 impulse response: ~A" data)))
(let ((hlb (make-hilbert-transform 7))
@@ -7955,7 +7912,7 @@ EDITS: 5
(do ((i 0 (+ i 1)))
((= i 20))
(set! (data i) (hilbert-transform hlb (if (= i 0) 1.0 0.0))))
- (if (not (vequal data (float-vector -0.007 0.0 -0.032 0.0 -0.136 0.0 -0.608 0.0 0.608 0.0 0.136 0.0 0.032 0.0 0.007 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector -0.007 0.0 -0.032 0.0 -0.136 0.0 -0.608 0.0 0.608 0.0 0.136 0.0 0.032 0.0 0.007 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";hilbert-transform 7 impulse response: ~A" data)))
(let ((ind (new-sound "test.snd")))
@@ -8032,7 +7989,7 @@ EDITS: 5
(set! (edit-position ind 0) edpos)
(f2)
(let ((v2 (channel->float-vector 0 100 ind 0)))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
(set! (edit-position ind 0) edpos)))
(if try-scale
@@ -8044,7 +8001,7 @@ EDITS: 5
(f2)
(scale-by 2.0)
(let ((v2 (channel->float-vector 0 100 ind 0)))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";scaled (2) env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
(set! (edit-position ind 0) edpos)))
(f1)
@@ -8054,7 +8011,7 @@ EDITS: 5
(scale-by .5)
(f2)
(let ((v2 (channel->float-vector 0 100 ind 0)))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";scaled (.5) env reordering test ~A:~%; ~A~%; ~A" name v1 v2))
(set! (edit-position ind 0) edpos)))))))
@@ -8115,9 +8072,9 @@ EDITS: 5
(if (not (= (edit-position ind 0) 1))
(snd-display ";as-one-edit 1 edpos: ~A" (edit-position ind 0))
(begin
- (if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("set-sample 10 1.0000" "set" 10 1)))
(snd-display ";as-one-edit 1 edlist: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-fragment 0 ind 0) (list "" "init" 0 50828)))
+ (if (not (equal? (edit-fragment 0 ind 0) '("" "init" 0 50828)))
(snd-display ";as-one-edit 1 original edlist: ~A" (edit-fragment 0 ind 0)))))
(revert-sound ind)
@@ -8130,7 +8087,7 @@ EDITS: 5
(if (fneq (sample 10) 2.0) (snd-display ";as-one-edit 2: ~A" (sample 10)))
(if (not (= (edit-position ind 0) 1))
(snd-display ";as-one-edit 2 edpos: ~A" (edit-position ind 0))
- (if (not (equal? (edit-fragment 0 ind 0) (list "" "init" 0 50828)))
+ (if (not (equal? (edit-fragment 0 ind 0) '("" "init" 0 50828)))
(snd-display ";as-one-edit 2 original edlist: ~A" (edit-fragment 0 ind 0))))
(revert-sound ind)
@@ -8146,11 +8103,11 @@ EDITS: 5
(if (not (= (edit-position ind 0) 1)) (snd-display ";as-one-edit 3 edpos: ~A" (edit-position ind 0)))
(if (not (= (edit-position ind2 0) 1)) (snd-display ";as-one-edit 3 2 edpos: ~A" (edit-position ind2 0)))
(if (not (= (edit-position ind2 1) 1)) (snd-display ";as-one-edit 3 2 1 edpos: ~A" (edit-position ind2 1)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("set-sample 10 1.0000" "set" 10 1)))
(snd-display ";as-one-edit 3 edlist: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-fragment 1 ind2 0) (list "set-sample 1 1.0000" "set" 1 1)))
+ (if (not (equal? (edit-fragment 1 ind2 0) '("set-sample 1 1.0000" "set" 1 1)))
(snd-display ";as-one-edit 3 2 edlist: ~A" (edit-fragment 1 ind2 0)))
- (if (not (equal? (edit-fragment 1 ind2 1) (list "set-sample 2 0.5000" "set" 2 1)))
+ (if (not (equal? (edit-fragment 1 ind2 1) '("set-sample 2 0.5000" "set" 2 1)))
(snd-display ";as-one-edit 3 2 1 edlist: ~A" (edit-fragment 1 ind2 1)))
(revert-sound ind)
@@ -8164,9 +8121,9 @@ EDITS: 5
(if (fneq (sample 10) 2.0) (snd-display ";as-one-edit 4: ~A" (sample 10 ind 0)))
(if (not (= (edit-position ind 0) 1))
(snd-display ";as-one-edit 4 edpos: ~A" (edit-position ind 0)))
- (if (not (equal? (edit-fragment 1 ind2 0) (list "set-sample 1 1.0000" "set" 1 1)))
+ (if (not (equal? (edit-fragment 1 ind2 0) '("set-sample 1 1.0000" "set" 1 1)))
(snd-display ";as-one-edit 3 2 edlist: ~A" (edit-fragment 1 ind2 0)))
- (if (not (equal? (edit-fragment 1 ind2 1) (list "set-sample 2 0.5000" "set" 2 1)))
+ (if (not (equal? (edit-fragment 1 ind2 1) '("set-sample 2 0.5000" "set" 2 1)))
(snd-display ";as-one-edit 3 2 1 edlist: ~A" (edit-fragment 1 ind2 1)))
(revert-sound ind)
@@ -8185,13 +8142,13 @@ EDITS: 5
(if (not (= (edit-position ind2 0) 2)) (snd-display ";as-one-edit 5 2 edpos: ~A" (edit-position ind2 0)))
(if (not (= (edit-position ind2 1) 2)) (snd-display ";as-one-edit 5 2 1 edpos: ~A" (edit-position ind2 1)))
- (if (not (equal? (edit-fragment 2 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
+ (if (not (equal? (edit-fragment 2 ind 0) '("set-sample 10 1.0000" "set" 10 1)))
(snd-display ";as-one-edit 5 edlist 2: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 3 1.0000" "set" 3 1)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("set-sample 3 1.0000" "set" 3 1)))
(snd-display ";as-one-edit 5 edlist 1: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-fragment 0 ind 0) (list "" "init" 0 50828)))
+ (if (not (equal? (edit-fragment 0 ind 0) '("" "init" 0 50828)))
(snd-display ";as-one-edit 5 original edlist: ~A" (edit-fragment 0 ind 0)))
- (if (not (equal? (edit-fragment 2 ind2 0) (list "set-sample 10 0.5000" "set" 10 1)))
+ (if (not (equal? (edit-fragment 2 ind2 0) '("set-sample 10 0.5000" "set" 10 1)))
(snd-display ";as-one-edit 5 edlist 2 1: ~A" (edit-fragment 1 ind2 0)))
(as-one-edit
@@ -8209,9 +8166,9 @@ EDITS: 5
(if (not (= (edit-position ind2 0) 2)) (snd-display ";as-one-edit 6 2 edpos: ~A" (edit-position ind2 0)))
(if (not (= (edit-position ind2 1) 3)) (snd-display ";as-one-edit 6 2 1 edpos: ~A" (edit-position ind2 1)))
- (if (not (equal? (edit-fragment 2 ind 0) (list "set-sample 10 1.0000" "set" 10 1)))
+ (if (not (equal? (edit-fragment 2 ind 0) '("set-sample 10 1.0000" "set" 10 1)))
(snd-display ";as-one-edit 5 edlist 2: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-fragment 2 ind2 0) (list "set-sample 10 0.5000" "set" 10 1)))
+ (if (not (equal? (edit-fragment 2 ind2 0) '("set-sample 10 0.5000" "set" 10 1)))
(snd-display ";as-one-edit 5 edlist 2 1: ~A" (edit-fragment 1 ind2 0)))
(close-sound ind2))
@@ -8236,7 +8193,7 @@ EDITS: 5
(begin
(snd-display ";nested as-one-edit 7 squelch is on")
(set! (squelch-update) #f)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "set-sample 300 0.6000" "set" 100 204)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("set-sample 300 0.6000" "set" 100 204)))
(snd-display ";as-one-edit 7 edlist: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
@@ -8255,7 +8212,7 @@ EDITS: 5
(snd-display ";nested as-one-edit 8: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
(if (not (= (edit-position ind 0) 1))
(snd-display ";nested as-one-edit 8 edpos: ~A" (edit-position ind 0)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit test-8" "set" 100 204)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("as-one-edit test-8" "set" 100 204)))
(snd-display ";as-one-edit 8 edlist: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
@@ -8275,7 +8232,7 @@ EDITS: 5
(snd-display ";nested as-one-edit 9: ~A ~A ~A" (sample 100) (sample 200) (sample 300)))
(if (not (= (edit-position ind 0) 1))
(snd-display ";nested as-one-edit 9 edpos: ~A" (edit-position ind 0)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit test-9" "set" 100 204)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("as-one-edit test-9" "set" 100 204)))
(snd-display ";as-one-edit 9 edlist: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
@@ -8300,7 +8257,7 @@ EDITS: 5
(snd-display ";nested as-one-edit 10: ~A ~A ~A ~A" (sample 100) (sample 200) (sample 300) (sample 400)))
(if (not (= (edit-position ind 0) 1))
(snd-display ";nested as-one-edit 10 edpos: ~A" (edit-position ind 0)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit test-10" "set" 100 305)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("as-one-edit test-10" "set" 100 305)))
(snd-display ";as-one-edit 10 edlist: ~A" (edit-fragment 1 ind 0)))
;; try implicit as-one-edits nested
@@ -8308,7 +8265,7 @@ EDITS: 5
(env-channel-with-base '(0 0 1 1 2 .5 3 .25 4 0) 0.0 0 #f ind 0)
(if (not (= (edit-position ind 0) 1)) (snd-display ";as-one-edit 11 edpos: ~A" (edit-position ind 0)))
(if (not (equal? (edit-fragment 1 ind 0)
- (list "env-channel-with-base '(0.000 0.000 1.000 1.000 2.000 0.500 3.000 0.250 4.000 0.000) 0.0000 0 #f" "scale" 0 50830)))
+ '("env-channel-with-base '(0.000 0.000 1.000 1.000 2.000 0.500 3.000 0.250 4.000 0.000) 0.0000 0 #f" "scale" 0 50830)))
(snd-display ";as-one-edit 11: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
@@ -8317,7 +8274,7 @@ EDITS: 5
(env-channel-with-base '(0 0 1 1 2 .5 3 .25 4 0) 0.0 0 #f ind 0))
"as-one-edit 12")
(if (not (= (edit-position ind 0) 1)) (snd-display ";as-one-edit 12 edpos: ~A" (edit-position ind 0)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit 12" "scale" 0 50830)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("as-one-edit 12" "scale" 0 50830)))
(snd-display ";as-one-edit 12: ~A" (edit-fragment 1 ind 0)))
(revert-sound ind)
@@ -8412,9 +8369,9 @@ EDITS: 1
(if (not (sound? ind2)) (snd-display ";as-one-edit didn't open sound? ~A ~A" ind2 (sounds)))
(if (not (= (edit-position ind2 0) 1)) (snd-display ";edpos as-one-edit opened sound: ~A" (edit-position ind2 0)))
(if (not (= (edit-position ind 0) 1)) (snd-display ";edpos as-one-edit original sound: ~A" (edit-position ind 0)))
- (if (not (equal? (edit-fragment 1 ind 0) (list "as-one-edit+open" "set" 100 1)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("as-one-edit+open" "set" 100 1)))
(snd-display ";as-one-edit open sound edlist orig: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-fragment 1 ind2 0) (list "set-sample 200 0.6000" "set" 200 1)))
+ (if (not (equal? (edit-fragment 1 ind2 0) '("set-sample 200 0.6000" "set" 200 1)))
(snd-display ";as-one-edit open sound edlist new: ~A" (edit-fragment 1 ind2 0)))
(as-one-edit
@@ -8496,25 +8453,25 @@ EDITS: 2
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "more tests" 10)))
;; offset-channel
(offset-channel .1)
- (if (not (vequal (channel->float-vector 0 10) (make-float-vector 10 .1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (make-float-vector 10 .1)))
(snd-display ";offset-channel (.1): ~A" (channel->float-vector 0 10)))
(offset-channel -.2 5 5)
- (if (not (vequal (channel->float-vector 0 10) (float-vector .1 .1 .1 .1 .1 -.1 -.1 -.1 -.1 -.1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (float-vector .1 .1 .1 .1 .1 -.1 -.1 -.1 -.1 -.1)))
(snd-display ";offset-channel (-.1): ~A" (channel->float-vector 0 10)))
(undo)
(offset-channel .9 0 10 ind 0)
- (if (not (vequal (channel->float-vector 0 10) (make-float-vector 10 1.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (make-float-vector 10 1.0)))
(snd-display ";offset-channel (1): ~A" (channel->float-vector 0 10)))
;; sine-env and sine-ramp...
(revert-sound ind)
(map-channel (lambda (y) 1.0))
(sine-ramp 0.0 1.0)
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.024 0.095 0.206 0.345 0.500 0.655 0.794 0.905 0.976)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.000 0.024 0.095 0.206 0.345 0.500 0.655 0.794 0.905 0.976)))
(snd-display ";sine-ramp 0 1: ~A" (channel->float-vector)))
(revert-sound ind)
(offset-channel 1.0)
(sine-ramp 1.0 0.0)
- (if (not (vequal (channel->float-vector) (float-vector 1.000 0.976 0.905 0.794 0.655 0.500 0.345 0.206 0.095 0.024)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 1.000 0.976 0.905 0.794 0.655 0.500 0.345 0.206 0.095 0.024)))
(snd-display ";sine-ramp 1 0: ~A" (channel->float-vector)))
(close-sound ind)
(set! ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next "sine-env tests" 100))
@@ -8524,9 +8481,9 @@ EDITS: 2
(revert-sound ind)
(offset-channel -1.0)
(sine-env-channel '(0 0 1 1 2 1 3 0) 40 20)
- (if (not (and (vequal (channel->float-vector 40 20) (float-vector -0.000 -0.050 -0.188 -0.389 -0.611 -0.812 -0.950 -1.000 -1.000 -1.000
+ (if (not (and (mus-arrays-equal? (channel->float-vector 40 20) (float-vector -0.000 -0.050 -0.188 -0.389 -0.611 -0.812 -0.950 -1.000 -1.000 -1.000
-1.000 -1.000 -1.000 -1.000 -1.000 -0.950 -0.812 -0.611 -0.389 -0.188))
- (vequal (channel->float-vector 30 10) (make-float-vector 10 -1.0))))
+ (mus-arrays-equal? (channel->float-vector 30 10) (make-float-vector 10 -1.0))))
(snd-display ";off+sine-env: ~A ~A" (channel->float-vector 40 20) (channel->float-vector 30 10)))
(revert-sound ind)
(scale-by 0.0)
@@ -8568,7 +8525,7 @@ EDITS: 2
(undo)
(blackman4-env-channel '(0 0 1 1))
(let ((new-vals (channel->float-vector)))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";blackman4-env-channel/ramp: ~A ~A" vals new-vals))
(undo)
(blackman4-ramp 0.0 1.0 0 50)
@@ -8576,11 +8533,11 @@ EDITS: 2
(undo)
(blackman4-env-channel '(0 0 1 1 2 1))
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";blackman4-env-channel/ramp 1: ~A ~A" vals new-vals))
(undo)
(blackman4-env-channel '(0 0 1 1 2 -.5 3 0))
- (if (not (vequal (channel->float-vector 60 10) (float-vector -0.109 -0.217 -0.313 -0.392 -0.451 -0.488 -0.499 -0.499 -0.499 -0.499)))
+ (if (not (mus-arrays-equal? (channel->float-vector 60 10) (float-vector -0.109 -0.217 -0.313 -0.392 -0.451 -0.488 -0.499 -0.499 -0.499 -0.499)))
(snd-display ";blackman4 to -.5: ~A" (channel->float-vector 60 10)))
(undo)
@@ -8589,7 +8546,7 @@ EDITS: 2
(undo)
(env-squared-channel '(0 0 1 1))
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-squared/ramp: ~A ~A" vals new-vals))
(undo)
(ramp-squared 0.0 1.0 #t 0 50)
@@ -8597,15 +8554,15 @@ EDITS: 2
(undo)
(env-squared-channel '(0 0 1 1 2 1))
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-squared/ramp 1: ~A ~A" vals new-vals))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0))
- (if (not (vequal (channel->float-vector 60 10) (float-vector -0.450 -0.466 -0.478 -0.488 -0.494 -0.499 -0.500 -0.500 -0.498 -0.496)))
+ (if (not (mus-arrays-equal? (channel->float-vector 60 10) (float-vector -0.450 -0.466 -0.478 -0.488 -0.494 -0.499 -0.500 -0.500 -0.498 -0.496)))
(snd-display ";env-squared to -.5: ~A" (channel->float-vector 60 10)))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0) #f)
- (if (not (vequal (channel->float-vector 60 10) (float-vector -0.004 -0.080 -0.158 -0.240 -0.324 -0.410 -0.500 -0.500 -0.498 -0.496)))
+ (if (not (mus-arrays-equal? (channel->float-vector 60 10) (float-vector -0.004 -0.080 -0.158 -0.240 -0.324 -0.410 -0.500 -0.500 -0.498 -0.496)))
(snd-display ";env-squared unsymmetric to -.5: ~A" (channel->float-vector 60 10)))
(undo)
@@ -8614,7 +8571,7 @@ EDITS: 2
(undo)
(env-expt-channel '(0 0 1 1) 2)
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-expt2/ramp: ~A ~A" vals new-vals))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0))
@@ -8622,7 +8579,7 @@ EDITS: 2
(undo)
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 2.0)
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-expt2/env-squared: ~A ~A" vals new-vals))
(undo)
(env-squared-channel '(0 0 1 1 2 -.5 3 0) #f)
@@ -8630,7 +8587,7 @@ EDITS: 2
(undo)
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 2.0 #f)
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-expt2/env-squared unsymmetric: ~A ~A" vals new-vals))
(undo)
@@ -8639,7 +8596,7 @@ EDITS: 2
(undo)
(env-expt-channel '(0 0 1 1) 32.0)
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-expt/ramp 32: ~A ~A" vals new-vals))
(undo)
(ramp-expt 0.0 1.0 32.0 #f 0 50)
@@ -8647,7 +8604,7 @@ EDITS: 2
(undo)
(env-expt-channel '(0 0 1 1 2 1) 32.0)
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-expt/ramp 1 32: ~A ~A" vals new-vals))
(undo)
(ramp-expt 0.0 1.0 .1)
@@ -8655,16 +8612,16 @@ EDITS: 2
(undo)
(env-expt-channel '(0 0 1 1) .1)
(set! new-vals (channel->float-vector))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";env-expt/ramp .1: ~A ~A" vals new-vals))
(undo)
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 12.0)
- (if (not (vequal (channel->float-vector 30 10) (float-vector 0.319 0.472 0.691 1.000 0.537 0.208 -0.022 -0.182 -0.291 -0.365)))
+ (if (not (mus-arrays-equal? (channel->float-vector 30 10) (float-vector 0.319 0.472 0.691 1.000 0.537 0.208 -0.022 -0.182 -0.291 -0.365)))
(snd-display ";env-expt to -.5 12.0: ~A" (channel->float-vector 30 10)))
(undo)
(env-expt-channel '(0 0 1 1 2 -.5 3 0) 12.0 #f)
- (if (not (vequal (channel->float-vector 30 10) (float-vector 0.319 0.472 0.691 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 30 10) (float-vector 0.319 0.472 0.691 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
(snd-display ";env-expt to -.5 12.0 unsymmetric: ~A" (channel->float-vector 30 10)))
(undo)
(close-sound ind))))
@@ -8693,7 +8650,7 @@ EDITS: 2
(if clip (snd-display ";channel-clipped? oboe.snd -> ~A" clip)))
(scale-to 1.5 ind0 0)
(let ((clip (channel-clipped? ind0 0)))
- (if (not (member clip '(4502 4503))) (snd-display ";channel-clipped after scale: ~A" clip)))
+ (if (not (memv clip '(4502 4503))) (snd-display ";channel-clipped after scale: ~A" clip)))
(revert-sound ind0)
(do ((i 0 (+ i 1))) ((= i 4)) (ramp-channel 0.0 1.0 0 #f ind1 0))
@@ -8723,7 +8680,7 @@ EDITS: 2
(if (not (= (chans s1) (chans s2) 1)) (snd-display ";copy sounds chans: ~A ~A" (chans s1) (chans s2)))
(let ((d1 (channel->float-vector 0 #f s1))
(d2 (channel->float-vector 0 #f s2)))
- (if (not (vequal d1 d2))
+ (if (not (mus-arrays-equal? d1 d2))
(snd-display ";copied sound not equal? ~A?" (float-vector-peak (float-vector-subtract! d0 d1)))))
(close-sound s2))))
(fill! s1 0.0)
@@ -8744,9 +8701,9 @@ EDITS: 2
(d11 (channel->float-vector 0 #f s1 1))
(d20 (channel->float-vector 0 #f s2 0))
(d21 (channel->float-vector 0 #f s2 1)))
- (if (not (vequal d10 d20))
+ (if (not (mus-arrays-equal? d10 d20))
(snd-display ";copied sound 2 (0) not equal? ~A?" (float-vector-peak (float-vector-subtract! d10 d20))))
- (if (not (vequal d11 d21))
+ (if (not (mus-arrays-equal? d11 d21))
(snd-display ";copied sound 2 (1) not equal? ~A?" (float-vector-peak (float-vector-subtract! d11 d21)))))
(close-sound s2))))
(fill! s1 0.0)
@@ -8763,11 +8720,11 @@ EDITS: 2
(copy (selection))
(let ((r1 (channel->float-vector 1000 1000 snd 0)))
(let* ((snds (sounds))
- (sel (if (equal? (car snds) snd) (cadr snds) (car snds)))
+ (sel ((if (equal? (car snds) snd) cadr car) snds))
(r2 (channel->float-vector 0 1000 sel 0)))
(if (equal? sel snd)
(snd-display ";very weird: ~A equal? ~A from ~A (~A ~A ~A)" sel snd snds (car snds) (cadr snds) (equal? (car snds) snd)))
- (if (not (vequal r1 r2))
+ (if (not (mus-arrays-equal? r1 r2))
(snd-display ";copied selection not equal? ~A?" (float-vector-peak (float-vector-subtract! r1 r2))))
(close-sound sel))
(if (not (selection?))
@@ -8870,15 +8827,15 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (sample i ind 0) (* .1 i)))
- (let ((rd (make-sampler 3 ind 0)))
- (let ((val (read-sample-with-direction rd 1)))
- (if (fneq val .3) (snd-display ";read-sample-with-direction 3: ~A" val))
- (read-sample-with-direction rd -1)
- (set! val (read-sample-with-direction rd -1))
- (if (fneq val .2) (snd-display ";read-sample-with-direction 2: ~A" val))
- (set! val (read-sample-with-direction rd -1))
- (if (fneq val .1) (snd-display ";read-sample-with-direction 1: ~A" val))
- (close-sound ind))))
+ (let* ((rd (make-sampler 3 ind 0))
+ (val (read-sample-with-direction rd 1)))
+ (if (fneq val .3) (snd-display ";read-sample-with-direction 3: ~A" val))
+ (read-sample-with-direction rd -1)
+ (set! val (read-sample-with-direction rd -1))
+ (if (fneq val .2) (snd-display ";read-sample-with-direction 2: ~A" val))
+ (set! val (read-sample-with-direction rd -1))
+ (if (fneq val .1) (snd-display ";read-sample-with-direction 1: ~A" val))
+ (close-sound ind)))
(clear-save-state-files))
@@ -8906,7 +8863,7 @@ EDITS: 2
(if (fneq (v3 0) 1.0) (snd-display ";set! float-vector-ref: ~A" (v3 0))))
(let ((vlst (make-float-vector 3)))
(set! (vlst 1) .1)
- (if (not (feql (map values vlst) (list 0.0 0.1 0.0))) (snd-display ";vector->list: ~A?" (map values vlst))))
+ (if (not (feql (map values vlst) '(0.0 0.1 0.0))) (snd-display ";vector->list: ~A?" (map values vlst))))
(let ((v2 (make-float-vector 4)))
(do ((i 0 (+ i 1)))
((= i 4))
@@ -8918,15 +8875,15 @@ EDITS: 2
(if (not (string=? (float-vector->string (float-vector 1.0 2.0)) "(float-vector 1.000 2.000)"))
(snd-display ";float-vector->string: ~A" (float-vector->string (float-vector 1.0 2.0))))
- (if (not (vequal (float-vector 4 3 2 1) (reverse! (float-vector 1 2 3 4)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3 4))))
- (if (not (vequal (float-vector 3 2 1) (reverse! (float-vector 1 2 3)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3))))
- (if (not (vequal (float-vector 2 1) (reverse! (float-vector 1 2)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2))))
- (if (not (vequal (float-vector 1) (reverse! (float-vector 1)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1))))
- (if (not (vequal (float-vector 3 2 1) (reverse (float-vector 1 2 3)))) (snd-display ";reverse(float-vector): ~A" (reverse (float-vector 1 2 3))))
- (let ((v (float-vector 3 2 1)))
- (let ((rv (reverse v)))
- (if (not (vequal rv (float-vector 1 2 3)))
- (snd-display ";reverse(float-vector) -> ~A ~A" v rv))))
+ (if (not (mus-arrays-equal? (float-vector 4 3 2 1) (reverse! (float-vector 1 2 3 4)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3 4))))
+ (if (not (mus-arrays-equal? (float-vector 3 2 1) (reverse! (float-vector 1 2 3)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2 3))))
+ (if (not (mus-arrays-equal? (float-vector 2 1) (reverse! (float-vector 1 2)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1 2))))
+ (if (not (mus-arrays-equal? (float-vector 1) (reverse! (float-vector 1)))) (snd-display ";float-vector-reverse: ~A" (reverse! (float-vector 1))))
+ (if (not (mus-arrays-equal? (float-vector 3 2 1) (reverse (float-vector 1 2 3)))) (snd-display ";reverse(float-vector): ~A" (reverse (float-vector 1 2 3))))
+ (let* ((v (float-vector 3 2 1))
+ (rv (reverse v)))
+ (if (not (mus-arrays-equal? rv (float-vector 1 2 3)))
+ (snd-display ";reverse(float-vector) -> ~A ~A" v rv)))
(let ((v0 (make-float-vector 3)))
(let ((var (catch #t (lambda () (v0 10)) (lambda args args))))
@@ -8949,15 +8906,15 @@ EDITS: 2
(snd-display ";float-vector-move! back high 2 index: ~A" var))))
(let ((v (float-vector 0.0 1.0 -2.0 -3.0)))
- (if (not (vequal (float-vector-abs! v) (float-vector 0.0 1.0 2.0 3.0)))
+ (if (not (mus-arrays-equal? (float-vector-abs! v) (float-vector 0.0 1.0 2.0 3.0)))
(snd-display ";float-vector-abs! ~A" v)))
;; float-vector-add! + shared-vector:
- (let ((fv (float-vector 1 2 3 4 5)))
- (let ((sv (make-shared-vector fv '(4) 1)))
- (float-vector-add! sv fv)
- (if (not (vequal fv (float-vector 1.0 3.0 6.0 10.0 15.0)))
- (snd-display ";float-vector+shared-vector: ~A" fv))))
+ (let* ((fv (float-vector 1 2 3 4 5))
+ (sv (make-shared-vector fv '(4) 1)))
+ (float-vector-add! sv fv)
+ (if (not (mus-arrays-equal? fv (float-vector 1.0 3.0 6.0 10.0 15.0)))
+ (snd-display ";float-vector+shared-vector: ~A" fv)))
(do ((i 0 (+ i 1)))
((= i 10))
@@ -9033,20 +8990,20 @@ EDITS: 2
(let ((v1 (make-float-vector 3 .1))
(v2 (make-float-vector 4 .2)))
(let ((val (float-vector+ (copy v1) v2)))
- (if (not (vequal val (float-vector .3 .3 .3))) (snd-display ";float-vector+ .1 .2: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector .3 .3 .3))) (snd-display ";float-vector+ .1 .2: ~A" val)))
(set! (v1 1) .3)
(let ((val (float-vector+ (copy v1) v2)))
- (if (not (vequal val (float-vector .3 .5 .3))) (snd-display ";float-vector+ .1 .2 (1): ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector .3 .5 .3))) (snd-display ";float-vector+ .1 .2 (1): ~A" val)))
(let ((val (float-vector+ (copy v1) 2.0)))
- (if (not (vequal val (float-vector 2.1 2.3 2.1))) (snd-display ";float-vector+ .1 2.0: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 2.1 2.3 2.1))) (snd-display ";float-vector+ .1 2.0: ~A" val)))
(let ((val (float-vector+ 2.0 (copy v1))))
- (if (not (vequal val (float-vector 2.1 2.3 2.1))) (snd-display ";float-vector+ .1 2.0 (1): ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 2.1 2.3 2.1))) (snd-display ";float-vector+ .1 2.0 (1): ~A" val)))
(let ((val (float-vector* 2.0 (copy v1))))
- (if (not (vequal val (float-vector .2 .6 .2))) (snd-display ";float-vector* 2.0: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector .2 .6 .2))) (snd-display ";float-vector* 2.0: ~A" val)))
(let ((val (float-vector* (copy v1) 2.0)))
- (if (not (vequal val (float-vector .2 .6 .2))) (snd-display ";float-vector* 2.0 (1): ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector .2 .6 .2))) (snd-display ";float-vector* 2.0 (1): ~A" val)))
(let ((val (float-vector* (copy v1) v2)))
- (if (not (vequal val (float-vector .02 .06 .02))) (snd-display ";float-vector* v1 v2: ~A" val))))
+ (if (not (mus-arrays-equal? val (float-vector .02 .06 .02))) (snd-display ";float-vector* v1 v2: ~A" val))))
(fill! v0 1.0)
(do ((i 0 (+ i 1)))
@@ -9092,16 +9049,15 @@ EDITS: 2
(revert-sound)
(close-sound ind)))
- (let ((hi (make-float-vector 3)))
- (let ((tag (catch #t
- (lambda () (float-vector-subseq hi 1 0))
- (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range))
- (snd-display ";float-vector-subseq 1 0: ~A" tag))))
+ (let ((tag (catch #t
+ (lambda () (float-vector-subseq (make-float-vector 3) 1 0))
+ (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range))
+ (snd-display ";float-vector-subseq 1 0: ~A" tag)))
(let ((v0 (make-float-vector 5 .1))
(v1 (make-float-vector 6 .2)))
(float-vector-add! v0 v1 2)
- (if (not (vequal v0 (float-vector .1 .1 .3 .3 .3)))
+ (if (not (mus-arrays-equal? v0 (float-vector .1 .1 .3 .3 .3)))
(snd-display ";float-vector-add + offset: ~A" v0)))
;; check s7 stuff with float-vectors
@@ -9123,10 +9079,10 @@ EDITS: 2
(if (not (eqv? val 6))
(snd-display ";float-vector s7 for-each: ~A" val)))
(set! v (reverse v))
- (if (not (vvequal v (float-vector 3.0 2.0 1.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 3.0 2.0 1.0)))
(snd-display ";float-vector s7 reverse: ~A" v))
(fill! v 12.0)
- (if (not (vvequal v (float-vector 12.0 12.0 12.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 12.0 12.0 12.0)))
(snd-display ";float-vector s7 fill: ~A" (fill! v 12.0)))
)
@@ -9155,502 +9111,502 @@ EDITS: 2
(require snd-rgb.scm)
(define (snd_test_7)
- (define colormap-error-max 0.0)
- (define cfneq (lambda (a b) (> (abs (- a b)) colormap-error-max)))
- (define old-colormap-size *colormap-size*)
- (define beige (*rgb* 'beige))
-
(when (or (provided? 'snd-gtk)
(provided? 'snd-motif))
- (letrec ((test-color
- (lambda (lst)
- (if (pair? lst)
- (let* ((name ((car lst) 0))
- (getfnc ((car lst) 1))
- (setfnc (lambda (val) (set! (getfnc) val)))
- (initval ((car lst) 2)))
- (if (not (color? initval)) (snd-display ";~A not color?" initval))
- ;; we'll get warnings here if the cell chosen didn't exactly match the one requested -- not a bug
- ;; (if (not (equal? (getfnc) initval))
- ;; (snd-display ";~A is not ~A (~A)?" name initval (getfnc)))
- (setfnc beige)
- (if (not (equal? (getfnc) beige))
- (snd-display ";set-~A is not beige (~A)?" name (getfnc)))
- (setfnc initval)
- (test-color (cdr lst)))))))
-
- (let* ((c1 (catch 'no-such-color
- (lambda () (make-color 0 0 1))
- (lambda args #f)))
- (c2 c1)
- (c3 (catch 'no-such-color
- (lambda () (make-color 0 0 1))
- (lambda args #f))))
- (if (not (equal? c1 c2)) (snd-display ";color not equal? ~A ~A?" c1 c2))
- (if (not (eq? c1 c2)) (snd-display ";color not eq? ~A ~A?" c1 c2))
+
+ (let* ((colormap-error-max 0.0)
+ (cfneq (lambda (a b) (> (abs (- a b)) colormap-error-max)))
+ (old-colormap-size *colormap-size*))
+
+ (letrec ((test-color
+ (lambda (lst)
+ (if (pair? lst)
+ (let* ((name ((car lst) 0))
+ (getfnc ((car lst) 1))
+ (setfnc (lambda (val) (set! (getfnc) val)))
+ (initval ((car lst) 2)))
+ (if (not (color? initval)) (snd-display ";~A not color?" initval))
+ ;; we'll get warnings here if the cell chosen didn't exactly match the one requested -- not a bug
+ ;; (if (not (equal? (getfnc) initval))
+ ;; (snd-display ";~A is not ~A (~A)?" name initval (getfnc)))
+ (let ((beige (*rgb* 'beige)))
+ (setfnc beige)
+ (if (not (equal? (getfnc) beige))
+ (snd-display ";set-~A is not beige (~A)?" name (getfnc))))
+ (setfnc initval)
+ (test-color (cdr lst)))))))
+
+ (let* ((c1 (catch 'no-such-color
+ (lambda () (make-color 0 0 1))
+ (lambda args #f)))
+ (c2 c1)
+ (c3 (catch 'no-such-color
+ (lambda () (make-color 0 0 1))
+ (lambda args #f))))
+ (if (not (equal? c1 c2)) (snd-display ";color not equal? ~A ~A?" c1 c2))
+ (if (not (eq? c1 c2)) (snd-display ";color not eq? ~A ~A?" c1 c2))
;(if (not (equal? c1 c3)) (snd-display ";diff color not equal? ~A ~A?" c1 c3))
- (if (eq? c1 c3) (snd-display ";diff color eq? ~A ~A?" c1 c3))
- (if (not (or (equal? (color->list c1) (list 0.0 0.0 1.0))
- (equal? (color->list c1) (list 0.0 0.0 1.0 1.0))))
- (snd-display ";color->list: ~A ~A?" c1 (color->list c1))))
-
- (if (not (provided? 'snd-motif))
- (let* ((c1 (catch 'no-such-color
- (lambda () (make-color 0 0 1 0.5))
- (lambda args #f)))
- (c2 c1)
- (c3 (catch 'no-such-color
- (lambda () (make-color 0 0 1 0.5))
- (lambda args #f))))
- (if (not (equal? c1 c2)) (snd-display ";alpha color not equal? ~A ~A?" c1 c2))
- (if (not (eq? c1 c2)) (snd-display ";alpha color not eq? ~A ~A?" c1 c2))
+ (if (eq? c1 c3) (snd-display ";diff color eq? ~A ~A?" c1 c3))
+ (if (not (member (color->list c1) '((0.0 0.0 1.0) (0.0 0.0 1.0 1.0))))
+ (snd-display ";color->list: ~A ~A?" c1 (color->list c1))))
+
+ (if (not (provided? 'snd-motif))
+ (let* ((c1 (catch 'no-such-color
+ (lambda () (make-color 0 0 1 0.5))
+ (lambda args #f)))
+ (c2 c1)
+ (c3 (catch 'no-such-color
+ (lambda () (make-color 0 0 1 0.5))
+ (lambda args #f))))
+ (if (not (equal? c1 c2)) (snd-display ";alpha color not equal? ~A ~A?" c1 c2))
+ (if (not (eq? c1 c2)) (snd-display ";alpha color not eq? ~A ~A?" c1 c2))
;(if (not (equal? c1 c3)) (snd-display ";alpha diff color not equal? ~A ~A?" c1 c3))
- (if (eq? c1 c3) (snd-display ";alpha diff color eq? ~A ~A?" c1 c3))
- (let ((c4 (catch 'no-such-color
- (lambda () (make-color 0 0 1 0.0))
- (lambda args #f))))
- (if (equal? c1 c4) (snd-display ";alpha color equal? ~A ~A?" c1 c2)))))
-
- (do ((i 0 (+ i 1)))
- ((not (colormap? (integer->colormap i))))
- (let ((val (colormap-ref (integer->colormap i) 0))
- (true-val ((list '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 1.0 1.0)
- '(0.0 0.0 7.01915007248035e-4) '(0.0 0.0 0.0) '(0.0 0.0 0.0)
- '(0.0 0.0 0.49999) '(1.0 0.0 0.0) '(1.0 0.0 0.0) '(0.0 0.0 1.0)
- '(1.0 0.0 1.0) '(0.0 0.500007629510948 0.4) '(1.0 0.0 0.0)
- '(1.0 0.0 0.0) '(0.0 0.0 1.0))
- i)))
- (if (not (feql val true-val))
- (snd-display ";colormap-ref ~A: ~A (~A)" i val true-val))))
- (catch #t ; might be undefined var as well as no-such-color
- (lambda ()
- (test-color
- (list
- (list 'basic-color basic-color ivory2)
- (list 'cursor-color cursor-color red)
- (list 'data-color data-color black)
- (list 'enved-waveform-color enved-waveform-color blue)
- (list 'filter-control-waveform-color filter-control-waveform-color blue)
- (list 'graph-color graph-color white)
- (list 'highlight-color highlight-color ivory1)
- (list 'listener-color listener-color alice-blue)
- (list 'listener-text-color listener-text-color black)
- (list 'mark-color mark-color red)
- (list 'mix-color mix-color dark-gray)
- (list 'position-color position-color ivory3)
- (list 'sash-color sash-color light-green)
- (list 'selected-data-color selected-data-color black)
- (list 'selected-graph-color selected-graph-color white)
- (list 'selection-color selection-color lightsteelblue1)
- (list 'text-focus-color text-focus-color white)
- (list 'zoom-color zoom-color ivory4)
- ))
-
- (let ((ind (open-sound "oboe.snd")))
- (set! *selected-data-color* light-green)
- (set! *data-color* blue)
- (set! *selected-graph-color* black)
- (let ((red (make-color-with-catch 1.0 0.0 0.0)))
- (set! (foreground-color ind 0 cursor-context) red)
- (let ((col (foreground-color ind 0 cursor-context)))
- (if (not (feql (color->list col) (color->list red)))
- (snd-display ";set foreground cursor color: ~A ~A" (color->list col) (color->list red))))
- (set! (foreground-color) blue)
- (let ((col (foreground-color)))
- (if (not (feql (color->list col) (color->list blue)))
- (snd-display ";set foreground-color: ~A ~A" (color->list col) (color->list blue))))
- (set! (foreground-color ind) red)
- (let ((col (foreground-color ind)))
- (if (not (feql (color->list col) (color->list red)))
- (snd-display ";set foreground-color with ind (red): ~A ~A" (color->list col) (color->list red))))
- (set! (foreground-color ind) black)
- (let ((col (foreground-color ind)))
- (if (not (feql (color->list col) (color->list black)))
- (snd-display ";set foreground-color with ind (black): ~A ~A" (color->list col) (color->list black)))))
- (set! *selected-graph-color* (make-color-with-catch 0.96 0.96 0.86))
- (set! *data-color* black)
- (set! *selected-data-color* blue)
- (set! *graph-color* white)
- (close-sound ind)))
- (lambda args args))
-
- (if (not (= (length jet-colormap) *colormap-size*))
- (snd-display ";jet-colormap length: ~A ~A" (length jet-colormap) *colormap-size*))
-
- (for-each
- (lambda (n err)
- (let ((inv (- 1.0 (/ 1.0 n))))
- (set! *colormap-size* n)
- (set! colormap-error-max err)
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r (if (< x 3/4)
- (* 7/8 x)
- (- (* 11/8 x) 3/8)))
- (g (if (< x 3/8)
- (* 7/8 x)
- (if (< x 3/4)
- (- (* 29/24 x) 1/8)
- (+ (* 7/8 x) 1/8))))
- (b (if (< x 3/8)
- (* 29/24 x)
- (+ (* 7/8 x) 1/8)))
- (rgb (colormap-ref bone-colormap x))
- (rgb1 (bone-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2))
- (r2 (rgb1 0))
- (g2 (rgb1 1))
- (b2 (rgb1 2)))
- (if (and (< x inv)
- (or (cfneq r r1)
- (cfneq g g1)
- (cfneq b b1)
- (cfneq r2 r1)
- (cfneq g2 g1)
- (cfneq b2 b1)))
- (snd-display ";bone ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r (if (< x 4/5)
- (* 5/4 x)
- 1.0))
- (g (* 4/5 x))
- (b (* 1/2 x))
- (rgb (colormap-ref copper-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";copper ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r 0.0)
- (g x)
- (b (- 1.0 (/ g 2.0)))
- (rgb (colormap-ref winter-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";winter ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r 1.0)
- (g x)
- (b 0.0)
- (rgb (colormap-ref autumn-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";autumn ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r x)
- (g (- 1.0 r))
- (b 1.0)
- (rgb (colormap-ref cool-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";cool ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r (if (< x 3/8)
- (* 8/3 x)
- 1.0))
- (g (if (< x 3/8)
- 0.0
- (if (< x 3/4)
- (- (* 8/3 x) 1.0)
- 1.0)))
- (b (if (< x 3/4)
- 0.0
- (- (* 4 x) 3)))
- (rgb (colormap-ref hot-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";hot ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r (cond ((< x 3/8) 0.0)
- ((< x 5/8) (- (* 4 x) 3/2))
- ((< x 7/8) 1.0)
- (else (+ (* -4 x) 9/2))))
- (g (cond ((< x 1/8) 0.0)
- ((< x 3/8) (- (* 4 x) 1/2))
- ((< x 5/8) 1.0)
- ((< x 7/8) (+ (* -4 x) 7/2))
- (else 0.0)))
- (b (cond ((< x 1/8) (+ (* 4 x) 1/2))
- ((< x 3/8) 1.0)
- ((< x 5/8) (+ (* -4 x) 5/2))
- (else 0.0)))
- (rgb (colormap-ref jet-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";jet ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (when (colormap? pink-colormap)
+ (if (eq? c1 c3) (snd-display ";alpha diff color eq? ~A ~A?" c1 c3))
+ (let ((c4 (catch 'no-such-color
+ (lambda () (make-color 0 0 1 0.0))
+ (lambda args #f))))
+ (if (equal? c1 c4) (snd-display ";alpha color equal? ~A ~A?" c1 c2)))))
+
+ (do ((i 0 (+ i 1)))
+ ((not (colormap? (integer->colormap i))))
+ (let ((val (colormap-ref (integer->colormap i) 0))
+ (true-val ((list '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 0.0 0.0) '(0.0 1.0 1.0)
+ '(0.0 0.0 7.01915007248035e-4) '(0.0 0.0 0.0) '(0.0 0.0 0.0)
+ '(0.0 0.0 0.49999) '(1.0 0.0 0.0) '(1.0 0.0 0.0) '(0.0 0.0 1.0)
+ '(1.0 0.0 1.0) '(0.0 0.500007629510948 0.4) '(1.0 0.0 0.0)
+ '(1.0 0.0 0.0) '(0.0 0.0 1.0))
+ i)))
+ (if (not (feql val true-val))
+ (snd-display ";colormap-ref ~A: ~A (~A)" i val true-val))))
+ (catch #t ; might be undefined var as well as no-such-color
+ (lambda ()
+ (test-color
+ (list
+ (list 'basic-color basic-color ivory2)
+ (list 'cursor-color cursor-color red)
+ (list 'data-color data-color black)
+ (list 'enved-waveform-color enved-waveform-color blue)
+ (list 'filter-control-waveform-color filter-control-waveform-color blue)
+ (list 'graph-color graph-color white)
+ (list 'highlight-color highlight-color ivory1)
+ (list 'listener-color listener-color alice-blue)
+ (list 'listener-text-color listener-text-color black)
+ (list 'mark-color mark-color red)
+ (list 'mix-color mix-color dark-gray)
+ (list 'position-color position-color ivory3)
+ (list 'sash-color sash-color light-green)
+ (list 'selected-data-color selected-data-color black)
+ (list 'selected-graph-color selected-graph-color white)
+ (list 'selection-color selection-color lightsteelblue1)
+ (list 'text-focus-color text-focus-color white)
+ (list 'zoom-color zoom-color ivory4)
+ ))
+
+ (let ((ind (open-sound "oboe.snd")))
+ (set! *selected-data-color* light-green)
+ (set! *data-color* blue)
+ (set! *selected-graph-color* black)
+ (let ((red (make-color-with-catch 1.0 0.0 0.0)))
+ (set! (foreground-color ind 0 cursor-context) red)
+ (let ((col (foreground-color ind 0 cursor-context)))
+ (if (not (feql (color->list col) (color->list red)))
+ (snd-display ";set foreground cursor color: ~A ~A" (color->list col) (color->list red))))
+ (set! (foreground-color) blue)
+ (let ((col (foreground-color)))
+ (if (not (feql (color->list col) (color->list blue)))
+ (snd-display ";set foreground-color: ~A ~A" (color->list col) (color->list blue))))
+ (set! (foreground-color ind) red)
+ (let ((col (foreground-color ind)))
+ (if (not (feql (color->list col) (color->list red)))
+ (snd-display ";set foreground-color with ind (red): ~A ~A" (color->list col) (color->list red))))
+ (set! (foreground-color ind) black)
+ (let ((col (foreground-color ind)))
+ (if (not (feql (color->list col) (color->list black)))
+ (snd-display ";set foreground-color with ind (black): ~A ~A" (color->list col) (color->list black)))))
+ (set! *selected-graph-color* (make-color-with-catch 0.96 0.96 0.86))
+ (set! *data-color* black)
+ (set! *selected-data-color* blue)
+ (set! *graph-color* white)
+ (close-sound ind)))
+ (lambda args args))
+
+ (if (not (= (length jet-colormap) *colormap-size*))
+ (snd-display ";jet-colormap length: ~A ~A" (length jet-colormap) *colormap-size*))
+
+ (for-each
+ (lambda (n err)
+ (let ((inv (- 1.0 (/ 1.0 n))))
+ (set! *colormap-size* n)
+ (set! colormap-error-max err)
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r (if (< x 3/4)
+ (* 7/8 x)
+ (- (* 11/8 x) 3/8)))
+ (g (if (< x 3/8)
+ (* 7/8 x)
+ (if (< x 3/4)
+ (- (* 29/24 x) 1/8)
+ (+ (* 7/8 x) 1/8))))
+ (b (if (< x 3/8)
+ (* 29/24 x)
+ (+ (* 7/8 x) 1/8)))
+ (rgb (colormap-ref bone-colormap x))
+ (rgb1 (bone-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2))
+ (r2 (rgb1 0))
+ (g2 (rgb1 1))
+ (b2 (rgb1 2)))
+ (if (and (< x inv)
+ (or (cfneq r r1)
+ (cfneq g g1)
+ (cfneq b b1)
+ (cfneq r2 r1)
+ (cfneq g2 g1)
+ (cfneq b2 b1)))
+ (snd-display ";bone ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r (if (< x 4/5)
+ (* 5/4 x)
+ 1.0))
+ (g (* 4/5 x))
+ (b (* 1/2 x))
+ (rgb (colormap-ref copper-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";copper ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r 0.0)
+ (g x)
+ (b (- 1.0 (/ g 2.0)))
+ (rgb (colormap-ref winter-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";winter ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r 1.0)
+ (g x)
+ (b 0.0)
+ (rgb (colormap-ref autumn-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";autumn ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r x)
+ (g (- 1.0 r))
+ (b 1.0)
+ (rgb (colormap-ref cool-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";cool ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
(do ((i 0 (+ i 1))) ((= i 10))
(let* ((x (random 1.0))
(r (if (< x 3/8)
- (* 14/9 x)
- (+ (* 2/3 x) 1/3)))
+ (* 8/3 x)
+ 1.0))
(g (if (< x 3/8)
- (* 2/3 x)
+ 0.0
(if (< x 3/4)
- (- (* 14/9 x) 1/3)
- (+ (* 2/3 x) 1/3))))
+ (- (* 8/3 x) 1.0)
+ 1.0)))
(b (if (< x 3/4)
- (* 2/3 x)
- (- (* 2 x) 1)))
- (rgb (colormap-ref pink-colormap x))
+ 0.0
+ (- (* 4 x) 3)))
+ (rgb (colormap-ref hot-colormap x))
(r1 (rgb 0))
(g1 (rgb 1))
(b1 (rgb 2)))
(if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";pink ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r 1.0)
- (g x)
- (b (- 1.0 g))
- (rgb (colormap-ref spring-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";spring ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r x)
- (g x)
- (b x)
- (rgb (colormap-ref gray-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";gray ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r 0.0)
- (g 0.0)
- (b 0.0)
- (rgb (colormap-ref black-and-white-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";black-and-white ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r x)
- (g (+ 0.5 (/ r 2)))
- (b 0.4)
- (rgb (colormap-ref summer-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";summer ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (r (cond ((< x 2/5) 1.0)
- ((< x 3/5) (+ (* -5 x) 3))
- ((< x 4/5) 0.0)
- (else (- (* 10/3 x) 8/3))))
- (g (cond ((< x 2/5) (* 5/2 x))
- ((< x 3/5) 1.0)
- ((< x 4/5) (+ (* -5 x) 4))
- (else 0.0)))
- (b (cond ((< x 3/5) 0.0)
- ((< x 4/5) (- (* 5 x) 3))
- (else 1.0)))
- (rgb (colormap-ref rainbow-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";rainbow ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (rgb (colormap-ref prism-colormap x)))
- (if (not (or (>= x inv)
- (feql rgb '(1 0 0))
- (feql rgb '(1 0.5 0))
- (feql rgb '(1 1 0))
- (feql rgb '(0 1 0))
- (feql rgb '(0 0 1))
- (feql rgb '(0.6667000000000001 0 1))))
- (snd-display ";prism ~A" rgb))))
-
- (do ((i 0 (+ i 1))) ((= i 10))
- (let* ((x (random 1.0))
- (rgb (colormap-ref flag-colormap x)))
- (if (not (or (>= x inv)
- (feql rgb '(1 0 0))
- (feql rgb '(1 1 1))
- (feql rgb '(0 0 1))
- (feql rgb '(0 0 0))))
- (snd-display ";flag: ~A" rgb))))
- ))
- (list 512 64)
- (list 0.005 0.04))
-
- (let ((ind (add-colormap "white" (lambda (size) (list (make-float-vector size 1.0) (make-float-vector size 1.0) (make-float-vector size 1.0))))))
- (if (not (colormap? ind))
- (snd-display ";add-colormap ~A: ~A" ind (colormap? ind)))
- (if (not (feql (colormap-ref ind 0.5) '(1.0 1.0 1.0)))
- (snd-display ";white colormap: ~A" (colormap-ref ind 0.5)))
- (let ((tag (catch #t (lambda () (set! *colormap* ind)) (lambda args args))))
- (if (or (eq? tag 'no-such-colormap)
- (not (equal? *colormap* ind))
- (not (= (colormap->integer *colormap*) (colormap->integer ind))))
- (snd-display ";colormap white: ~A ~A ~A" tag ind *colormap*)))
- (if (not (string=? (colormap-name ind) "white"))
- (snd-display ";white colormap name: ~A" (colormap-name ind))))
-
- (let ((tag (catch #t (lambda () (delete-colormap (integer->colormap 1234))) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-colormap))
- (snd-display ";delete-colormap 1234: ~A" tag)))
- (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap 1234) 0.5)) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-colormap))
- (snd-display ";colormap-ref 1234: ~A" tag)))
- (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap -1) 0.5)) (lambda args (car args)))))
- (if (not (memq tag '(no-such-colormap wrong-type-arg)))
- (snd-display ";colormap-ref -1: ~A" tag)))
- (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap 1234))) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-colormap))
- (snd-display "; set colormap 1234: ~A" tag)))
- (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap -1))) (lambda args (car args)))))
- (if (not (memq tag '(no-such-colormap wrong-type-arg)))
- (snd-display "; set colormap -1: ~A" tag)))
- (let ((tag (catch #t (lambda () (colormap-ref copper-colormap 2.0)) (lambda args (car args)))))
- (if (not (eq? tag 'out-of-range))
- (snd-display ";colormap-ref 2.0: ~A" tag)))
-
- (set! *colormap-size* old-colormap-size)
- (if (not (= *colormap-size* old-colormap-size))
- (snd-display ";set colormap-size: ~A ~A" *colormap-size* old-colormap-size))
-
- (if (not (string=? (colormap-name black-and-white-colormap) "black-and-white"))
- (snd-display ";black-and-white: ~A" (colormap-name black-and-white-colormap)))
- (if (not (string=? (colormap-name gray-colormap) "gray"))
- (snd-display ";gray: ~A" (colormap-name gray-colormap)))
- (if (not (string=? (colormap-name rainbow-colormap) "rainbow"))
- (snd-display ";rainbow: ~A" (colormap-name rainbow-colormap)))
-
- (let ()
- (add-colormap "purple"
- (lambda (size)
- (let ((r (make-float-vector size))
- (g (make-float-vector size))
- (b (make-float-vector size))
- (incr (/ 256.0 size))
- (er (list 0 60 60 116 128 252 192 252 256 60))
- (eg (list 0 0 64 0 128 252 192 252 256 0))
- (eb (list 0 80 128 252 192 0 256 80)))
- (do ((i 0 (+ i 1))
+ (snd-display ";hot ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r (cond ((< x 3/8) 0.0)
+ ((< x 5/8) (- (* 4 x) 3/2))
+ ((< x 7/8) 1.0)
+ (else (+ (* -4 x) 9/2))))
+ (g (cond ((< x 1/8) 0.0)
+ ((< x 3/8) (- (* 4 x) 1/2))
+ ((< x 5/8) 1.0)
+ ((< x 7/8) (+ (* -4 x) 7/2))
+ (else 0.0)))
+ (b (cond ((< x 1/8) (+ (* 4 x) 1/2))
+ ((< x 3/8) 1.0)
+ ((< x 5/8) (+ (* -4 x) 5/2))
+ (else 0.0)))
+ (rgb (colormap-ref jet-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";jet ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (when (colormap? pink-colormap)
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r (if (< x 3/8)
+ (* 14/9 x)
+ (+ (* 2/3 x) 1/3)))
+ (g (if (< x 3/8)
+ (* 2/3 x)
+ (if (< x 3/4)
+ (- (* 14/9 x) 1/3)
+ (+ (* 2/3 x) 1/3))))
+ (b (if (< x 3/4)
+ (* 2/3 x)
+ (- (* 2 x) 1)))
+ (rgb (colormap-ref pink-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";pink ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r 1.0)
+ (g x)
+ (b (- 1.0 g))
+ (rgb (colormap-ref spring-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";spring ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r x)
+ (g x)
+ (b x)
+ (rgb (colormap-ref gray-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";gray ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r 0.0)
+ (g 0.0)
+ (b 0.0)
+ (rgb (colormap-ref black-and-white-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";black-and-white ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r x)
+ (g (+ 0.5 (/ r 2)))
+ (b 0.4)
+ (rgb (colormap-ref summer-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";summer ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (r (cond ((< x 2/5) 1.0)
+ ((< x 3/5) (+ (* -5 x) 3))
+ ((< x 4/5) 0.0)
+ (else (- (* 10/3 x) 8/3))))
+ (g (cond ((< x 2/5) (* 5/2 x))
+ ((< x 3/5) 1.0)
+ ((< x 4/5) (+ (* -5 x) 4))
+ (else 0.0)))
+ (b (cond ((< x 3/5) 0.0)
+ ((< x 4/5) (- (* 5 x) 3))
+ (else 1.0)))
+ (rgb (colormap-ref rainbow-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and (< x inv) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";rainbow ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1)))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (rgb (colormap-ref prism-colormap x)))
+ (if (not (or (>= x inv)
+ (feql rgb '(1 0 0))
+ (feql rgb '(1 0.5 0))
+ (feql rgb '(1 1 0))
+ (feql rgb '(0 1 0))
+ (feql rgb '(0 0 1))
+ (feql rgb '(0.6667000000000001 0 1))))
+ (snd-display ";prism ~A" rgb))))
+
+ (do ((i 0 (+ i 1))) ((= i 10))
+ (let* ((x (random 1.0))
+ (rgb (colormap-ref flag-colormap x)))
+ (if (not (or (>= x inv)
+ (feql rgb '(1 0 0))
+ (feql rgb '(1 1 1))
+ (feql rgb '(0 0 1))
+ (feql rgb '(0 0 0))))
+ (snd-display ";flag: ~A" rgb))))
+ ))
+ '(512 64)
+ '(0.005 0.04))
+
+ (let ((ind (add-colormap "white" (lambda (size) (list (make-float-vector size 1.0) (make-float-vector size 1.0) (make-float-vector size 1.0))))))
+ (if (not (colormap? ind))
+ (snd-display ";add-colormap ~A: ~A" ind (colormap? ind)))
+ (if (not (feql (colormap-ref ind 0.5) '(1.0 1.0 1.0)))
+ (snd-display ";white colormap: ~A" (colormap-ref ind 0.5)))
+ (let ((tag (catch #t (lambda () (set! *colormap* ind)) (lambda args args))))
+ (if (or (eq? tag 'no-such-colormap)
+ (not (equal? *colormap* ind))
+ (not (= (colormap->integer *colormap*) (colormap->integer ind))))
+ (snd-display ";colormap white: ~A ~A ~A" tag ind *colormap*)))
+ (if (not (string=? (colormap-name ind) "white"))
+ (snd-display ";white colormap name: ~A" (colormap-name ind))))
+
+ (let ((tag (catch #t (lambda () (delete-colormap (integer->colormap 1234))) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-colormap))
+ (snd-display ";delete-colormap 1234: ~A" tag)))
+ (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap 1234) 0.5)) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-colormap))
+ (snd-display ";colormap-ref 1234: ~A" tag)))
+ (let ((tag (catch #t (lambda () (colormap-ref (integer->colormap -1) 0.5)) (lambda args (car args)))))
+ (if (not (memq tag '(no-such-colormap wrong-type-arg)))
+ (snd-display ";colormap-ref -1: ~A" tag)))
+ (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap 1234))) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-colormap))
+ (snd-display "; set colormap 1234: ~A" tag)))
+ (let ((tag (catch #t (lambda () (set! *colormap* (integer->colormap -1))) (lambda args (car args)))))
+ (if (not (memq tag '(no-such-colormap wrong-type-arg)))
+ (snd-display "; set colormap -1: ~A" tag)))
+ (let ((tag (catch #t (lambda () (colormap-ref copper-colormap 2.0)) (lambda args (car args)))))
+ (if (not (eq? tag 'out-of-range))
+ (snd-display ";colormap-ref 2.0: ~A" tag)))
+
+ (set! *colormap-size* old-colormap-size)
+ (if (not (= *colormap-size* old-colormap-size))
+ (snd-display ";set colormap-size: ~A ~A" *colormap-size* old-colormap-size))
+
+ (if (not (string=? (colormap-name black-and-white-colormap) "black-and-white"))
+ (snd-display ";black-and-white: ~A" (colormap-name black-and-white-colormap)))
+ (if (not (string=? (colormap-name gray-colormap) "gray"))
+ (snd-display ";gray: ~A" (colormap-name gray-colormap)))
+ (if (not (string=? (colormap-name rainbow-colormap) "rainbow"))
+ (snd-display ";rainbow: ~A" (colormap-name rainbow-colormap)))
+
+ (let ()
+ (add-colormap "purple"
+ (lambda (size)
+ (do ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
+ (incr (/ 256.0 size))
+ (er (list 0 60 60 116 128 252 192 252 256 60))
+ (eg (list 0 0 64 0 128 252 192 252 256 0))
+ (eb (list 0 80 128 252 192 0 256 80))
+ (i 0 (+ i 1))
(x 0.0 (+ x incr)))
- ((= i size))
+ ((= i size)
+ (list r g b))
(set! (r i) (/ (envelope-interp x er) 256.0))
(set! (g i) (/ (envelope-interp x eg) 256.0))
- (set! (b i) (/ (envelope-interp x eb) 256.0)))
- (list r g b))))
- (add-colormap "sin"
- (lambda (size)
- (let ((r (make-float-vector size))
- (g (make-float-vector size))
- (b (make-float-vector size))
- (incr (/ (* 2 pi) size)))
- (do ((i 0 (+ i 1))
+ (set! (b i) (/ (envelope-interp x eb) 256.0)))))
+ (add-colormap "sin"
+ (lambda (size)
+ (do ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
+ (incr (/ (* 2 pi) size))
+ (i 0 (+ i 1))
(x 0.0 (+ x incr)))
- ((= i size))
+ ((= i size)
+ (list r g b))
(set! (r i) (abs (sin (* 1.5 x))))
(set! (g i) (abs (sin (* 3.5 x))))
- (set! (b i) (abs (sin (* 2.5 x)))))
- (list r g b))))
- (add-colormap "another-sin"
- (lambda (size)
- (let ((r (make-float-vector size))
- (g (make-float-vector size))
- (b (make-float-vector size))
- (incr (/ (* 2 pi) size)))
- (do ((i 0 (+ i 1))
+ (set! (b i) (abs (sin (* 2.5 x)))))))
+
+ (add-colormap "another-sin"
+ (lambda (size)
+ (do ((r (make-float-vector size))
+ (g (make-float-vector size))
+ (b (make-float-vector size))
+ (incr (/ (* 2 pi) size))
+ (i 0 (+ i 1))
(x 0.0 (+ x incr)))
- ((= i size))
+ ((= i size)
+ (list r g b))
(set! (r i) (abs (sin (* 2.5 x))))
(set! (g i) (abs (sin (* 3.5 x))))
- (set! (b i) (abs (sin (* 4.5 x)))))
- (list r g b))))
-
- (delete-colormap pink-colormap)
- (if (colormap? pink-colormap)
- (snd-display ";delete-colormap ~A: ~A" pink-colormap (colormap? pink-colormap)))
- (let ((tag (catch #t (lambda () (set! *colormap* pink-colormap)) (lambda args args))))
- (if (or (not (eq? (car tag) 'no-such-colormap))
- (equal? *colormap* pink-colormap))
- (snd-display ";delete pink colormap: ~A ~A ~A" tag pink-colormap *colormap*)))
+ (set! (b i) (abs (sin (* 4.5 x)))))))
+
+ (delete-colormap pink-colormap)
+ (if (colormap? pink-colormap)
+ (snd-display ";delete-colormap ~A: ~A" pink-colormap (colormap? pink-colormap)))
+ (let ((tag (catch #t (lambda () (set! *colormap* pink-colormap)) (lambda args args))))
+ (if (or (not (eq? (car tag) 'no-such-colormap))
+ (equal? *colormap* pink-colormap))
+ (snd-display ";delete pink colormap: ~A ~A ~A" tag pink-colormap *colormap*)))
+
+ (for-each
+ (lambda (n)
+ (set! *colormap-size* n)
+ (do ((n2 (> n 2))
+ (n/n (- 1.0 (/ 1.0 n)))
+ (i 0 (+ i 1)))
+ ((= i 10))
+ (let* ((x (random 1.0))
+ (r (if (< x 4/5) (* 5/4 x) 1.0))
+ (g (* 4/5 x))
+ (b (* 1/2 x))
+ (rgb (colormap-ref copper-colormap x))
+ (r1 (rgb 0))
+ (g1 (rgb 1))
+ (b1 (rgb 2)))
+ (if (and n2 (< x n/n) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
+ (snd-display ";copper size reset ~A: ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
+ n x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
+ '(1024 256 2 512))
+ (set! *colormap-size* 512))
- (for-each
- (lambda (n)
- (set! *colormap-size* n)
- (do ((n2 (> n 2))
- (n/n (- 1.0 (/ 1.0 n)))
- (i 0 (+ i 1)))
- ((= i 10))
- (let* ((x (random 1.0))
- (r (if (< x 4/5) (* 5/4 x) 1.0))
- (g (* 4/5 x))
- (b (* 1/2 x))
- (rgb (colormap-ref copper-colormap x))
- (r1 (rgb 0))
- (g1 (rgb 1))
- (b1 (rgb 2)))
- (if (and n2 (< x n/n) (or (cfneq r r1) (cfneq g g1) (cfneq b b1)))
- (snd-display ";copper size reset ~A: ~,3F (~,3F): ~{~,3F ~} ~{~,3F ~}"
- n x (max (abs (- r r1)) (abs (- g g1)) (abs (- b b1))) (list r g b) (list r1 g1 b1))))))
- (list 1024 256 2 512))
- (set! *colormap-size* 512))
-
- (set! (hook-functions graph-hook) ())
- )))
-
+ (set! (hook-functions graph-hook) ())
+ ))))
;;; ---------------- test 8: clm ----------------
@@ -9839,7 +9795,7 @@ EDITS: 2
((> i n))
(set! frqs (cons (hz->radians (* i 400.0)) frqs)))
(reverse frqs)))
- (make-float-vector n 0.0)
+ (make-float-vector n)
(make-float-vector n (mus-scaler p))
#t)))
(do ((i 0 (+ i 1)))
@@ -9917,8 +9873,7 @@ EDITS: 2
(end 1)
(scl (exp (/ 4.0 (- end start))))) ; normalize it
(map-channel (lambda (y)
- (let ((val (if (or (<= x start) ; don't divide by zero
- (>= x end))
+ (let ((val (if (not (< start x end))
0.0
(exp (+ (/ -1.0 (- x start))
(/ -1.0 (- end x)))))))
@@ -9936,7 +9891,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 12))
(let ((val (sin (/ (* 2 pi i) 12.0))))
- (set! (x1 (+ i (- (/ size 4) 6))) val)))
+ (set! (x1 (- (+ i (/ size 4)) 6)) val)))
(let ((data (make-float-vector dur)))
(let ((recompute-samps 30) ;just a quick guess
(gen1 (make-table-lookup 440.0 :wave x1))
@@ -9969,7 +9924,7 @@ EDITS: 2
(set! (v i) (env e)))
v))
- (let ((tbl (envelope->float-vector (list 0.0 -1.0 1.0 1.0) 1001))
+ (let ((tbl (envelope->float-vector '(0.0 -1.0 1.0 1.0) 1001))
(curpos (edit-position snd chn)))
(map-channel (lambda (y)
(array-interp tbl (+ 500.0 (* y 500)) 1000))
@@ -10003,7 +9958,7 @@ EDITS: 2
;; from Verma, Bilbao, Meng, "The Digital Prolate Spheroidal Window"
;; output checked using Julius Smith's dpssw.m, although my "w" is different
(lambda (n w)
- (let ((mat (make-float-vector (list n n) 0.0))
+ (let ((mat (make-float-vector (list n n)))
(cw (cos (* 2 pi w))))
(do ((n-1 (- n 1))
(n/2 (* 0.5 (- n 1)))
@@ -10029,55 +9984,55 @@ EDITS: 2
;; ----------------
(define (test-lpc)
(define* (make-sine (n 16))
- (let ((data (make-float-vector n 0.0))
- (incr (/ (* 2.0 pi) n)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i n) data)
- (set! (data i) (sin x)))))
+ (do ((data (make-float-vector n))
+ (incr (/ (* 2.0 pi) n))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i n) data)
+ (set! (data i) (sin x))))
(define (make-sines n)
- (let ((data (make-float-vector n 0.0))
- (incr (/ (* 2.0 pi) n)))
- (do ((i 0 (+ i 1))
- (x 0.0 (+ x incr)))
- ((= i n) data)
- (set! (data i) (+ (sin x)
- (* .25 (sin (* 2.0 x)))
- (* .125 (sin (* 4.0 x))))))))
+ (do ((data (make-float-vector n))
+ (incr (/ (* 2.0 pi) n))
+ (i 0 (+ i 1))
+ (x 0.0 (+ x incr)))
+ ((= i n) data)
+ (set! (data i) (+ (sin x)
+ (* .25 (sin (* 2.0 x)))
+ (* .125 (sin (* 4.0 x)))))))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7) 8 (lpc-coeffs (float-vector 0 1 2 3 4 5 6 7) 8 4) 4 2)))
- (if (not (vequal vals (float-vector 7.906 8.557)))
+ (if (not (mus-arrays-equal? vals (float-vector 7.906 8.557)))
(snd-display ";predict ramp: ~A" vals)))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7) 8 (lpc-coeffs (float-vector 0 1 2 3 4 5 6 7) 8 7) 7 2)))
- (if (not (vequal vals (float-vector 7.971 8.816)))
+ (if (not (mus-arrays-equal? vals (float-vector 7.971 8.816)))
(snd-display ";predict ramp 1: ~A" vals)))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15
(lpc-coeffs (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15 7) 7 5)))
- (if (not (vequal vals (float-vector 14.999 15.995 16.980 17.940 18.851)))
+ (if (not (mus-arrays-equal? vals (float-vector 14.999 15.995 16.980 17.940 18.851)))
(snd-display ";predict ramp 2: ~A" vals)))
(let ((vals (lpc-predict (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15
(lpc-coeffs (float-vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14) 15 14) 14 5)))
- (if (not (vequal vals (float-vector 15.000 16.000 16.998 17.991 18.971)))
+ (if (not (mus-arrays-equal? vals (float-vector 15.000 16.000 16.998 17.991 18.971)))
(snd-display ";predict ramp 3: ~A" vals)))
(let ((vals (lpc-predict (make-sine) 16 (lpc-coeffs (make-sine) 16 8) 8 2)))
- (if (not (vequal vals (float-vector 0.000 0.383)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.383)))
(snd-display ";predict sine: ~A" vals)))
(let ((vals (lpc-predict (make-sine) 16 (lpc-coeffs (make-sine) 16 8) 8 8)))
- (if (not (vequal vals (float-vector 0.000 0.383 0.707 0.924 1.000 0.924 0.707 0.383)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.383 0.707 0.924 1.000 0.924 0.707 0.383)))
(snd-display ";predict sine 1: ~A" vals)))
(let ((vals (lpc-predict (make-sines 32) 32 (lpc-coeffs (make-sines 32) 32 8) 8 8)))
- (if (not (vequal vals (float-vector 0.000 0.379 0.686 0.880 0.970 1.001 1.022 1.053)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.379 0.686 0.880 0.970 1.001 1.022 1.053)))
(snd-display ";predict sines: ~A" vals)))
(let ((vals (lpc-predict (make-sines 32) 32 (lpc-coeffs (make-sines 32) 32 16) 16 8)))
- (if (not (or (vequal vals (float-vector 0.000 0.379 0.684 0.876 0.961 0.987 1.006 1.046))
- (vequal vals (float-vector 0.000 0.379 0.685 0.876 0.961 0.985 0.998 1.029))))
+ (if (not (or (mus-arrays-equal? vals (float-vector 0.000 0.379 0.684 0.876 0.961 0.987 1.006 1.046))
+ (mus-arrays-equal? vals (float-vector 0.000 0.379 0.685 0.876 0.961 0.985 0.998 1.029))))
(snd-display ";predict sines 1: ~A" vals)))
(let ((vals (lpc-predict (make-sines 32) 32 (lpc-coeffs (make-sines 32) 32 30) 30 4)))
- (if (not (or (vequal vals (float-vector 0.000 0.379 0.685 0.878))
- (vequal vals (float-vector 0.000 0.379 0.684 0.875)))) ; double float-vectors
+ (if (not (or (mus-arrays-equal? vals (float-vector 0.000 0.379 0.685 0.878))
+ (mus-arrays-equal? vals (float-vector 0.000 0.379 0.684 0.875)))) ; double float-vectors
(snd-display ";predict sines 2: ~A" vals)))
(let ((vals (lpc-predict (make-sines 64) 64 (lpc-coeffs (make-sines 64) 64 32) 32 8)))
- (if (not (vequal vals (float-vector 0.000 0.195 0.379 0.545 0.684 0.795 0.875 0.927)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.195 0.379 0.545 0.684 0.795 0.875 0.927)))
(snd-display ";predict sines 3: ~A" vals))))
;; ----------------
@@ -10101,7 +10056,7 @@ EDITS: 2
(if (fneq umax .999) (snd-display ";unclip-channel 0 oboe maxamp: ~A" umax)))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(e (make-env '(0 0 1 .8 1.5 1.0 2.0 1.0 2.5 .8 3.5 0) :length 101))
(o (make-oscil 1000)))
(do ((i 0 (+ i 1)))
@@ -10119,7 +10074,7 @@ EDITS: 2
(if (fneq umax .999) (snd-display ";unclip-channel 1 sine maxamp: ~A" umax)))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(e (make-env '(0 0 1 .8 1.75 1.0 2.0 1.0 2.25 .8 3.5 0) :length 101))
(o (make-oscil 1000)))
(do ((i 0 (+ i 1)))
@@ -10137,7 +10092,7 @@ EDITS: 2
(if (fneq umax .999) (snd-display ";unclip-channel 2 sine maxamp: ~A" umax)))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(e (make-env '(0 0 1 .8 1.85 1.0 2.0 1.0 2.15 .8 3.5 0) :length 101))
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
@@ -10156,7 +10111,7 @@ EDITS: 2
(if (fneq umax .999) (snd-display ";unclip-channel 3 sine maxamp: ~A" umax)))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(e (make-env '(0 0 40 .75 45 1.0 50 1.25 55 1.0 60 .75 100 0.0) :length 101))
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
@@ -10175,7 +10130,7 @@ EDITS: 2
(if (fneq umax .999) (snd-display ";unclip-channel 4 sine maxamp: ~A" umax)))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(o1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
((= i 100))
@@ -10194,7 +10149,7 @@ EDITS: 2
(if (fneq umax true-max) (snd-display ";unclip-channel 5 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(o1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
((= i 100))
@@ -10215,7 +10170,7 @@ EDITS: 2
(if (fneq umax true-max) (snd-display ";unclip-channel 6 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(o1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
((= i 100))
@@ -10236,7 +10191,7 @@ EDITS: 2
(if (fneq umax true-max) (snd-display ";unclip-channel 7 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
- (let ((data (make-float-vector 100 0.0))
+ (let ((data (make-float-vector 100))
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
(do ((i 0 (+ i 1)))
@@ -10258,7 +10213,7 @@ EDITS: 2
(if (fneq umax true-max) (snd-display ";unclip-channel 8 click maxamp: ~A ~A" umax true-max)))))
(revert-sound ind)
- (let ((data (make-float-vector 200 0.0))
+ (let ((data (make-float-vector 200))
(o1 (make-oscil 1000))
(o2 (make-oscil 2000)))
(do ((i 0 (+ i 1)))
@@ -10329,9 +10284,7 @@ EDITS: 2
(define* (sweep->bins flt (bins 10))
(let ((ind (open-sound "sweep.snd")))
- (if (mus-generator? flt)
- (clm-channel flt)
- (map-channel flt))
+ ((if (mus-generator? flt) clm-channel map-channel) flt)
(let ((mx (maxamp))
(resp (make-float-vector bins))
(size (round (/ 22050 bins)))
@@ -10352,28 +10305,29 @@ EDITS: 2
(define (filter-equal? f1 f2) ; equalp in clm2xen is too restrictive
(and (= (mus-order f1) (mus-order f2))
- (vequal (mus-xcoeffs f1) (mus-xcoeffs f2))
- (vequal (mus-ycoeffs f1) (mus-ycoeffs f2))))
+ (mus-arrays-equal? (mus-xcoeffs f1) (mus-xcoeffs f2))
+ (mus-arrays-equal? (mus-ycoeffs f1) (mus-ycoeffs f2))))
;; ---------------- butterworth tests ----------------
- (let ((poles (list (float-vector 1.000 1.414 1.000) ; numerous references provide these tables (y[0] is ignored)
+ (do ((poles (list (float-vector 1.000 1.414 1.000) ; numerous references provide these tables (y[0] is ignored)
(float-vector 1.000 1.848 1.000 1.000 0.765 1.000)
(float-vector 1.000 1.932 1.000 1.000 1.414 1.000 1.000 0.518 1.000)
(float-vector 1.000 1.962 1.000 1.000 1.663 1.000 1.000 1.111 1.000 1.000 0.390 1.000)
- (float-vector 1.000 1.975 1.000 1.000 1.782 1.000 1.000 1.414 1.000 1.000 0.908 1.000 1.000 0.313 1.000))))
- (do ((i 2 (+ i 2))
- (k 0 (+ k 1)))
- ((>= i 12))
- (let ((vals (butterworth-prototype i)))
- (if (not (vequal (cadr vals) (poles k)))
- (snd-display ";butterworth prototype poles ~A: ~A (~A)" i (cadr vals) (poles k)))
- (let ((zeros (make-float-vector (* (+ k 1) 3))))
- (do ((j 2 (+ j 3)))
- ((>= j (* (+ k 1) 3)))
- (set! (zeros j) 1.0))
- (if (not (vequal (car vals) zeros))
- (snd-display ";butterworth prototype zeros ~A: ~A (~A)" i (car vals) zeros))))))
+ (float-vector 1.000 1.975 1.000 1.000 1.782 1.000 1.000 1.414 1.000 1.000 0.908 1.000 1.000 0.313 1.000)))
+ (i 2 (+ i 2))
+ (k 0 (+ k 1)))
+ ((>= i 12))
+ (let ((vals (butterworth-prototype i)))
+ (if (not (mus-arrays-equal? (cadr vals) (poles k)))
+ (snd-display ";butterworth prototype poles ~A: ~A (~A)" i (cadr vals) (poles k)))
+ (let ((zeros (make-float-vector (* (+ k 1) 3))))
+ (do ((j 2 (+ j 3)))
+ ((>= j (* (+ k 1) 3)))
+ (set! (zeros j) 1.0))
+ (if (not (mus-arrays-equal? (car vals) zeros))
+ (snd-display ";butterworth prototype zeros ~A: ~A (~A)" i (car vals) zeros)))))
+
(do ((cutoff .1 (+ cutoff .1))
(m 0 (+ 1 m)))
((= m 3))
@@ -10407,91 +10361,77 @@ EDITS: 2
(save-sound ind)
(close-sound ind))
- (let* ((f1 (make-butterworth-lowpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-lowpass 8 .1))))
(if (fneq (car vals) .5) (snd-display ";butterworth lp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.359 0.014 0.001 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.359 0.014 0.001 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";butterworth lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-lowpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-lowpass 12 .25))))
(if (fneq (car vals) .5) (snd-display ";butterworth lp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.358 0.010 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.358 0.010 0.000 0.000 0.000)))
(snd-display ";butterworth lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-lowpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-lowpass 10 .4))))
(if (fneq (car vals) .5) (snd-display ";butterworth lp 10 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.361 0.001))
- (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.360 0.002))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.361 0.001))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.499 0.360 0.002))))
(snd-display ";butterworth lp 10 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 12))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-butterworth-lowpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-butterworth-lowpass i j))))
(if (> mx 1.0)
(snd-display ";butter low max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-butterworth-highpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-highpass 8 .1))))
(if (fneq (car vals) .5) (snd-display ";butterworth hp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.348 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.348 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500)))
(snd-display ";butterworth hp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-highpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-highpass 12 .25))))
(if (fneq (car vals) .5) (snd-display ";butterworth hp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.011 0.348 0.500 0.500 0.500 0.500 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.011 0.348 0.500 0.500 0.500 0.500 0.500)))
(snd-display ";butterworth hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-highpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-highpass 10 .4))))
(if (fneq (car vals) .5) (snd-display ";butterworth hp 10 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.005 0.343 0.501 0.501)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.005 0.343 0.501 0.501)))
(snd-display ";butterworth hp 10 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-bandpass 4 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-bandpass 4 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.028 0.350 0.481 0.479 0.346 0.132 0.038 0.009 0.002 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.028 0.350 0.481 0.479 0.346 0.132 0.038 0.009 0.002 0.000)))
(snd-display ";butterworth bp 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-bandpass 12 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-bandpass 12 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bp 12 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.006 0.317 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.012 0.319 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.000 0.323 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.006 0.317 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.012 0.319 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.323 0.501 0.500 0.358 0.009 0.000 0.000 0.000 0.000))))
(snd-display ";butterworth bp 12 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-bandpass 8 .3 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-bandpass 8 .3 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.003 0.034 0.344 0.499 0.499 0.353 0.002)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.003 0.034 0.344 0.499 0.499 0.353 0.002)))
(snd-display ";butterworth bp 8 .3 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 12))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-butterworth-highpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-butterworth-highpass i j))))
(if (> mx 1.0)
(snd-display ";butter high max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-butterworth-bandstop 4 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-bandstop 4 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bs 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.347 0.339 0.481 0.499 0.500 0.500 0.500 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.347 0.339 0.481 0.499 0.500 0.500 0.500 0.500)))
(snd-display ";butterworth bs 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-bandstop 12 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-bandstop 12 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bs 12 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.503 0.503 0.364 0.334 0.500 0.500 0.500 0.500 0.500 0.500))
- (vequal1 (cadr vals) (float-vector 0.502 0.503 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))
- (vequal1 (cadr vals) (float-vector 0.500 0.500 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.503 0.503 0.364 0.334 0.500 0.500 0.500 0.500 0.500 0.500))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.502 0.503 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.365 0.334 0.500 0.500 0.500 0.500 0.500 0.500))))
(snd-display ";butterworth bs 12 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-butterworth-bandstop 8 .3 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-butterworth-bandstop 8 .3 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";butterworth bs 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.498 0.354 0.332 0.500 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.498 0.354 0.332 0.500 0.500)))
(snd-display ";butterworth bs 8 .3 .4 spect: ~A" (cadr vals))))
@@ -10499,7 +10439,7 @@ EDITS: 2
;; ripple .01 .1 1 for 2..10 even
- (let ((poles-01 (list (float-vector 1.000 4.456 10.426)
+ (do ((poles-01 (list (float-vector 1.000 4.456 10.426)
(float-vector 1.000 0.822 2.006 1.000 1.984 1.299)
(float-vector 1.000 0.343 1.372 1.000 0.937 0.939 1.000 1.280 0.506)
(float-vector 1.000 0.189 1.196 1.000 0.537 0.925 1.000 0.804 0.542 1.000 0.948 0.272)
@@ -10518,259 +10458,221 @@ EDITS: 2
(float-vector 1.000 0.279 0.987 1.000 0.674 0.279)
(float-vector 1.000 0.124 0.991 1.000 0.340 0.558 1.000 0.464 0.125)
(float-vector 1.000 0.070 0.994 1.000 0.199 0.724 1.000 0.298 0.341 1.000 0.352 0.070)
- (float-vector 1.000 0.045 0.996 1.000 0.130 0.814 1.000 0.203 0.521 1.000 0.255 0.227 1.000 0.283 0.045))))
- (do ((i 2 (+ i 2))
- (k 0 (+ k 1)))
- ((>= i 12))
- (let ((vals (chebyshev-prototype i .01)))
- (if (not (vequal1 (cadr vals) (poles-01 k)))
- (snd-display ";chebyshev prototype .01 poles ~A: ~A (~A)" i (cadr vals) (poles-01 k))))
- (let ((vals (chebyshev-prototype i .1)))
- (if (not (vequal1 (cadr vals) (poles-1 k)))
- (snd-display ";chebyshev prototype .1 poles ~A: ~A (~A)" i (cadr vals) (poles-1 k))))
- (let ((vals (chebyshev-prototype i)))
- (if (not (vequal1 (cadr vals) (poles-10 k)))
- (snd-display ";chebyshev prototype 1 poles ~A: ~A (~A)" i (cadr vals) (poles-10 k)))
- (if (not (vequal (car vals) (zeros k)))
- (snd-display ";chebyshev prototype .01 zeros ~A: ~A (~A)" i (car vals) (zeros k))))))
-
- (let* ((f1 (make-chebyshev-lowpass 8 .1))
- (vals (sweep->bins f1)))
+ (float-vector 1.000 0.045 0.996 1.000 0.130 0.814 1.000 0.203 0.521 1.000 0.255 0.227 1.000 0.283 0.045)))
+ (i 2 (+ i 2))
+ (k 0 (+ k 1)))
+ ((>= i 12))
+ (let ((vals (chebyshev-prototype i .01)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (poles-01 k)))
+ (snd-display ";chebyshev prototype .01 poles ~A: ~A (~A)" i (cadr vals) (poles-01 k))))
+ (let ((vals (chebyshev-prototype i .1)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (poles-1 k)))
+ (snd-display ";chebyshev prototype .1 poles ~A: ~A (~A)" i (cadr vals) (poles-1 k))))
+ (let ((vals (chebyshev-prototype i)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (poles-10 k)))
+ (snd-display ";chebyshev prototype 1 poles ~A: ~A (~A)" i (cadr vals) (poles-10 k)))
+ (if (not (mus-arrays-equal? (car vals) (zeros k)))
+ (snd-display ";chebyshev prototype .01 zeros ~A: ~A (~A)" i (car vals) (zeros k)))))
+
+ (let ((vals (sweep->bins (make-chebyshev-lowpass 8 .1))))
(if (ffneq (car vals) .51) (snd-display ";chebyshev lp 8 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";chebyshev lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-lowpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-lowpass 12 .25))))
(if (ffneq (car vals) .51) (snd-display ";chebyshev lp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.509 0.500 0.508 0.508 0.507 0.413 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.509 0.500 0.508 0.508 0.507 0.413 0.000 0.000 0.000 0.000)))
(snd-display ";chebyshev lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-lowpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-lowpass 10 .4))))
(if (ffneq (car vals) .51) (snd-display ";chebyshev lp 10 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.465 0.493 0.509 0.508 0.477 0.507 0.508 0.507 0.431 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.465 0.493 0.509 0.508 0.477 0.507 0.508 0.507 0.431 0.000)))
(snd-display ";chebyshev lp 10 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-chebyshev-lowpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-chebyshev-lowpass i j))))
(if (> mx 1.0)
(snd-display ";cheby low max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-chebyshev-lowpass 8 .1 .01))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-lowpass 8 .1 .01))))
(if (ffneq (car vals) .49) (snd-display ";chebyshev lp 8 .1 .01 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.492 0.491 0.483 0.006 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.492 0.491 0.483 0.006 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";chebyshev lp 8 .1 .01 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-lowpass 12 .25 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-lowpass 12 .25 .1))))
(if (ffneq (car vals) .49) (snd-display ";chebyshev lp 12 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.488 0.488 0.488 0.488 0.487 0.403 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.488 0.488 0.488 0.488 0.487 0.403 0.000 0.000 0.000 0.000)))
(snd-display ";chebyshev lp 12 .25 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-lowpass 10 .4 .001))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-lowpass 10 .4 .001))))
(if (ffneq (car vals) .49) (snd-display ";chebyshev lp 10 .001 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.497 0.497 0.497 0.497 0.497 0.497 0.497 0.497 0.488 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.497 0.497 0.497 0.497 0.497 0.497 0.497 0.497 0.488 0.000)))
(snd-display ";chebyshev lp 10 .4 .001 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-highpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-highpass 8 .1))))
(if (ffneq (car vals) .55) (snd-display ";chebyshev hp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.341 0.551 0.509 0.466 0.501 0.509 0.505 0.481 0.461)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.341 0.551 0.509 0.466 0.501 0.509 0.505 0.481 0.461)))
(snd-display ";chebyshev hp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-highpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-highpass 12 .25))))
(if (ffneq (car vals) .55) (snd-display ";chebyshev hp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.299 0.554 0.509 0.509 0.500 0.509)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.299 0.554 0.509 0.509 0.500 0.509)))
(snd-display ";chebyshev hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-highpass 10 .4))
- (vals (sweep->bins f1)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.297 0.786 0.677))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.301 0.788 0.660))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.322 0.861 0.724))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.262 0.571 0.509))))
+ (let ((vals (sweep->bins (make-chebyshev-highpass 10 .4))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.297 0.786 0.677))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.301 0.788 0.660))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.322 0.861 0.724))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.262 0.571 0.509))))
(snd-display ";chebyshev hp 10 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-highpass 8 .1 .01))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-highpass 8 .1 .01))))
(if (ffneq (car vals) .49) (snd-display ";chebyshev hp 8 .1 .01 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.498 0.498 0.492 0.491 0.492 0.492 0.492 0.491 0.491)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.498 0.498 0.492 0.491 0.492 0.492 0.492 0.491 0.491)))
(snd-display ";chebyshev hp 8 .1 .01 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-highpass 12 .25 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-highpass 12 .25 .1))))
(if (ffneq (car vals) .51) (snd-display ";chebyshev hp 12 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.453 0.516 0.489 0.489 0.488 0.488)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.453 0.516 0.489 0.489 0.488 0.488)))
(snd-display ";chebyshev hp 12 .25 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-highpass 10 .4 .001))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-highpass 10 .4 .001))))
(if (ffneq (car vals) .5) (snd-display ";chebyshev hp 10 .001 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.501 0.504 0.504))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.505 0.504))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.501 0.497))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.501 0.504 0.504))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.505 0.504))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.002 0.503 0.501 0.497))))
(snd-display ";chebyshev hp 10 .4 .001 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-chebyshev-highpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-chebyshev-highpass i j))))
(if (> mx 1.0)
(snd-display ";cheby high max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-chebyshev-bandpass 4 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandpass 4 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.009 0.449 0.509 0.505 0.442 0.065 0.013 0.003 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.009 0.449 0.509 0.505 0.442 0.065 0.013 0.003 0.000 0.000)))
(snd-display ";chebyshev bp 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-bandpass 6 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandpass 6 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 6 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.376 0.505 0.498 0.412 0.011 0.001 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.376 0.505 0.498 0.412 0.011 0.001 0.000 0.000 0.000)))
(snd-display ";chebyshev bp 6 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-bandpass 8 .3 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandpass 8 .3 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.002 0.363 0.517 0.513 0.433 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.002 0.363 0.517 0.513 0.433 0.000)))
(snd-display ";chebyshev bp 8 .3 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-bandpass 8 .2 .2 .01))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandpass 8 .2 .2 .01))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bp 10 .2 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.015 0.483 0.482 0.021 0.001 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.015 0.483 0.482 0.021 0.001 0.000 0.000 0.000)))
(snd-display ";chebyshev bp 10 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-bandstop 4 .1 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandstop 4 .1 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bs 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.509 0.505 0.447 0.033 0.006 0.006 0.033 0.445 0.512 0.509)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.509 0.505 0.447 0.033 0.006 0.006 0.033 0.445 0.512 0.509)))
(snd-display ";chebyshev bs 4 .1 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-bandstop 8 .1 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandstop 8 .1 .4))))
(if (> (abs (- (car vals) .51)) .05) (snd-display ";chebyshev bs 8 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.001 0.345 0.551 0.507))
- (vequal1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.001 0.344 0.549 0.508))
- (vequal1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.001 0.345 0.552 0.508))
- (vequal1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.001 0.343 0.548 0.508))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.508 0.512 0.468 0.001 0.000 0.000 0.001 0.345 0.551 0.507))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.507 0.512 0.467 0.001 0.000 0.000 0.001 0.344 0.549 0.508))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.508 0.513 0.469 0.001 0.000 0.000 0.001 0.345 0.552 0.508))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.509 0.508 0.465 0.001 0.000 0.000 0.001 0.343 0.548 0.508))))
(snd-display ";chebyshev bs 8 .1 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-chebyshev-bandstop 8 .1 .4 .01))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-chebyshev-bandstop 8 .1 .4 .01))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";chebyshev bs 8 .01 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.492 0.491 0.483 0.006 0.000 0.000 0.006 0.494 0.495 0.492)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.492 0.491 0.483 0.006 0.000 0.000 0.006 0.494 0.495 0.492)))
(snd-display ";chebyshev bs 8 .1 .4 .01 spect: ~A" (cadr vals))))
;; ---------------- inverse-chebyshev ----------------
- (let* ((f1 (make-inverse-chebyshev-lowpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-lowpass 8 .1))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 8 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.501 0.496 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))
- (vequal1 (cadr vals) (float-vector 0.500 0.498 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.501 0.496 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.498 0.001 0.000 0.001 0.000 0.000 0.000 0.000 0.001))))
(snd-display ";inverse-chebyshev lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-lowpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-lowpass 12 .25))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.496 0.001 0.001 0.001 0.001 0.001)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.496 0.001 0.001 0.001 0.001 0.001)))
(snd-display ";inverse-chebyshev lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-lowpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-lowpass 10 .4))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 10 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.001 0.001))
- (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.002 0.002))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.001 0.001))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.497 0.002 0.002))))
(snd-display ";inverse-chebyshev lp 10 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-lowpass 10 .4 120))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-lowpass 10 .4 120))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev lp 10 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.501 0.501 0.501 0.501 0.501 0.500 0.345 0.007 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.501 0.501 0.501 0.501 0.501 0.500 0.345 0.007 0.000 0.000)))
(snd-display ";inverse-chebyshev lp 10 .4 120 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-inverse-chebyshev-lowpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-inverse-chebyshev-lowpass i j))))
(if (> mx 1.0)
(snd-display ";inv cheby low max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-inverse-chebyshev-highpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-highpass 8 .1))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.440 0.505 0.505 0.503 0.502 0.501 0.501 0.501)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.001 0.440 0.505 0.505 0.503 0.502 0.501 0.501 0.501)))
(snd-display ";inverse-chebyshev hp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-highpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-highpass 12 .25))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.001 0.001 0.001 0.505 0.506 0.503 0.501 0.501)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.001 0.001 0.001 0.001 0.505 0.506 0.503 0.501 0.501)))
(snd-display ";inverse-chebyshev hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-highpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-highpass 10 .4))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 10 .4 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.503 0.503))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.505 0.503))
- (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.509 0.504))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.503 0.503))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.505 0.503))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.509 0.504))))
(snd-display ";inverse-chebyshev hp 10 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-highpass 10 .1 120))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-highpass 10 .1 120))))
(if (ffneq (car vals) .51) (snd-display ";inverse-chebyshev hp 10 .1 120 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.007 0.328 0.502 0.502 0.502 0.501 0.501 0.501)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.007 0.328 0.502 0.502 0.502 0.501 0.501 0.501)))
(snd-display ";inverse-chebyshev hp 10 .1 120 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 10))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-inverse-chebyshev-highpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-inverse-chebyshev-highpass i j))))
(if (> mx 1.0)
(snd-display ";inv cheby high max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-inverse-chebyshev-bandpass 10 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandpass 10 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.498 0.485 0.001 0.001 0.000 0.001 0.000 0.001)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.001 0.498 0.485 0.001 0.001 0.000 0.001 0.000 0.001)))
(snd-display ";inverse-chebyshev bp 10 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-bandpass 10 .1 .2 30))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandpass 10 .1 .2 30))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 6 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.026 0.025 0.509 0.505 0.020 0.016 0.012 0.016 0.011 0.016))
- (vequal1 (cadr vals) (float-vector 0.030 0.042 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))
- (vequal1 (cadr vals) (float-vector 0.022 0.017 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.026 0.025 0.509 0.505 0.020 0.016 0.012 0.016 0.011 0.016))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.030 0.042 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.022 0.017 0.511 0.505 0.020 0.016 0.012 0.016 0.011 0.016))))
(snd-display ";inverse-chebyshev bp 10 .1 .2 30 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-bandpass 8 .1 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandpass 8 .1 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.001 0.440 0.506 0.505 0.503 0.502 0.434 0.001 0.001)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.001 0.440 0.506 0.505 0.503 0.502 0.434 0.001 0.001)))
(snd-display ";inverse-chebyshev bp 8 .1 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-bandpass 8 .3 .4 40))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandpass 8 .3 .4 40))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bp 10 .2 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.002 0.005 0.007 0.007 0.005 0.005 0.503 0.505 0.006 0.005)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.002 0.005 0.007 0.007 0.005 0.005 0.503 0.505 0.006 0.005)))
(snd-display ";inverse-chebyshev bp 10 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-bandstop 4 .1 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandstop 4 .1 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bs 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.054 0.001 0.001 0.000 0.000 0.000 0.001 0.055 0.503)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.054 0.001 0.001 0.000 0.000 0.000 0.001 0.055 0.503)))
(snd-display ";inverse-chebyshev bs 4 .1 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-bandstop 8 .1 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandstop 8 .1 .4))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bs 8 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.501 0.496 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))
- (vequal1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.511))
- (vequal1 (cadr vals) (float-vector 0.500 0.498 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.501 0.496 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.511))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.498 0.001 0.001 0.000 0.000 0.000 0.001 0.507 0.506))))
(snd-display ";inverse-chebyshev bs 8 .1 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-inverse-chebyshev-bandstop 8 .1 .4 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-inverse-chebyshev-bandstop 8 .1 .4 90))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";inverse-chebyshev bs 8 90 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.505 0.325 0.000 0.000 0.000 0.000 0.000 0.000 0.270 0.506))
- (vequal1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.269 0.509))
- (vequal1 (cadr vals) (float-vector 0.501 0.327 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.506))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.505 0.325 0.000 0.000 0.000 0.000 0.000 0.000 0.270 0.506))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.506 0.328 0.000 0.000 0.000 0.000 0.000 0.000 0.269 0.509))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.501 0.327 0.000 0.000 0.000 0.000 0.000 0.000 0.268 0.506))))
(snd-display ";inverse-chebyshev bs 8 .1 .4 90 spect: ~A" (cadr vals))))
@@ -10779,163 +10681,134 @@ EDITS: 2
;; checked poly coeff tables, but the prototype has scaling built in
(when (provided? 'gsl)
- (let* ((f1 (make-bessel-lowpass 4 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-lowpass 4 .1))))
(if (fneq (car vals) .5) (snd-display ";bessel lp 4 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.417 0.209 0.062 0.018 0.005 0.001 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.417 0.209 0.062 0.018 0.005 0.001 0.000 0.000 0.000)))
(snd-display ";bessel lp 4 .1 spect: ~A" (cadr vals))))
-
- (let* ((f1 (make-bessel-lowpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-lowpass 8 .1))))
(if (fneq (car vals) .5) (snd-display ";bessel lp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.499 0.365 0.116 0.010 0.001 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.499 0.365 0.116 0.010 0.001 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";bessel lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-lowpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-lowpass 12 .25))))
(if (fneq (car vals) .5) (snd-display ";bessel lp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.477 0.410 0.309 0.185 0.063 0.006 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.477 0.410 0.309 0.185 0.063 0.006 0.000 0.000 0.000)))
(snd-display ";bessel lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-lowpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-lowpass 10 .4))))
(if (fneq (car vals) .5) (snd-display ";bessel lp 10 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.001))
- (vequal1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.002))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.001))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.498 0.491 0.479 0.458 0.423 0.364 0.259 0.086 0.002))))
(snd-display ";bessel lp 10 .4 spect: ~A" (cadr vals))))
(do ((i 2 (+ i 2)))
((= i 12))
(do ((j .1 (+ j .1)))
((>= j .45))
- (let* ((f1 (make-bessel-lowpass i j))
- (mx (filter-response-max f1)))
+ (let ((mx (filter-response-max (make-bessel-lowpass i j))))
(if (> mx 1.0)
(snd-display ";bess low max ~A ~A: ~A" i j mx)))))
- (let* ((f1 (make-bessel-highpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-highpass 8 .1))))
(if (fneq (car vals) .5) (snd-display ";bessel hp 8 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.001 0.115 0.290 0.386 0.435 0.465 0.483 0.493 0.498 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.001 0.115 0.290 0.386 0.435 0.465 0.483 0.493 0.498 0.500)))
(snd-display ";bessel hp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-highpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-highpass 12 .25))))
(if (fneq (car vals) .5) (snd-display ";bessel hp 12 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.006 0.063 0.181 0.309 0.410 0.477 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.006 0.063 0.181 0.309 0.410 0.477 0.500)))
(snd-display ";bessel hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-highpass 10 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-highpass 10 .4))))
(if (ffneq (car vals) .5) (snd-display ";bessel hp 10 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.004 0.084 0.343 0.499)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.004 0.084 0.343 0.499)))
(snd-display ";bessel hp 10 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-bandpass 4 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-bandpass 4 .1 .2))))
(if (> (abs (- (car vals) .245)) .05) (snd-display ";bessel bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.023 0.176 0.245 0.244 0.179 0.085 0.031 0.008 0.001 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.023 0.176 0.245 0.244 0.179 0.085 0.031 0.008 0.001 0.000)))
(snd-display ";bessel bp 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-bessel-bandstop 12 .1 .2))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-bessel-bandstop 12 .1 .2))))
(if (> (abs (- (car vals) .5)) .05) (snd-display ";bessel bs 12 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.498 0.325 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))
- (vequal1 (cadr vals) (float-vector 0.499 0.324 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.498 0.325 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.499 0.324 0.065 0.066 0.177 0.297 0.389 0.452 0.488 0.500))))
(snd-display ";bessel bs 12 .1 .2 spect: ~A" (cadr vals))))
;; ---------------- elliptic ----------------
- (let* ((f1 (make-elliptic-lowpass 8 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-lowpass 8 .1))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.515 0.379 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.500 0.509 0.385 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.499 0.498 0.373 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.515 0.379 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.509 0.385 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.499 0.498 0.373 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";elliptic lp 8 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 12 .25))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-lowpass 12 .25))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 12 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.412 0.003 0.001 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.561 0.004 0.000 0.000 0.000))
- (vequal1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.493 0.299 0.006 0.001 0.000 0.000))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.412 0.003 0.001 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.494 0.561 0.004 0.000 0.000 0.000))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.476 0.500 0.491 0.499 0.493 0.299 0.006 0.001 0.000 0.000))))
(snd-display ";elliptic lp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 4 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-lowpass 4 .4))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.447 0.453 0.462 0.477 0.494 0.500 0.497 0.496 0.445 0.003)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.447 0.453 0.462 0.477 0.494 0.500 0.497 0.496 0.445 0.003)))
(snd-display ";elliptic lp 4 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 8 .1 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-lowpass 8 .1 .1))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";elliptic lp 8 .1 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 8 .1 .1 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-lowpass 8 .1 .1 90))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 .1 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";elliptic lp 8 .1 .1 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-lowpass 8 .25 .01 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-lowpass 8 .25 .01 90))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic lp 8 .25 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.495 0.001 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.500 0.500 0.500 0.499 0.495 0.001 0.000 0.000 0.000)))
(snd-display ";elliptic lp 8 .25 .1 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 4 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-highpass 4 .1))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.004 0.438 0.516 0.499 0.502 0.495 0.478 0.463 0.453 0.447)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.004 0.438 0.516 0.499 0.502 0.495 0.478 0.463 0.453 0.447)))
(snd-display ";elliptic hp 4 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 12 .25))
- (vals (sweep->bins f1)))
- ;(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 12 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.026 0.934 0.518 0.495 0.503 0.477))
- (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.033 1.185 0.519 0.495 0.503 0.477))
- (vequal1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.018 0.788 0.520 0.495 0.503 0.477))))
+ (let ((vals (sweep->bins (make-elliptic-highpass 12 .25))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.026 0.934 0.518 0.495 0.503 0.477))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.033 1.185 0.519 0.495 0.503 0.477))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.001 0.001 0.001 0.018 0.788 0.520 0.495 0.503 0.477))))
(snd-display ";elliptic hp 12 .25 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 12 .25 .01 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-highpass 12 .25 .01 90))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 12 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.499 0.517 0.503 0.501 0.500 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.000 0.499 0.517 0.503 0.501 0.500 0.500)))
(snd-display ";elliptic hp 12 .25 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 4 .4))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-highpass 4 .4))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.002 0.023 0.447 0.515 0.502)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.001 0.002 0.023 0.447 0.515 0.502)))
(snd-display ";elliptic hp 4 .4 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 8 .1 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-highpass 8 .1 .1))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 8 .1 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.478 0.553 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.478 0.553 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
(snd-display ";elliptic hp 8 .1 .1 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 8 .1 .1 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-highpass 8 .1 .1 90))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 8 .1 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.478 0.554 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.478 0.554 0.506 0.499 0.501 0.501 0.499 0.497 0.495)))
(snd-display ";elliptic hp 8 .1 .1 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-highpass 8 .25 .01 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-highpass 8 .25 .01 90))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic hp 8 .25 90 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.516 0.517 0.507 0.503 0.501 0.500)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.000 0.000 0.000 0.001 0.516 0.517 0.507 0.503 0.501 0.500)))
(snd-display ";elliptic hp 8 .25 .1 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-bandpass 4 .1 .2 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-bandpass 4 .1 .2 .1))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bp 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.036 0.546 0.550 0.510 0.501 0.032 0.024 0.009 0.021 0.024)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.036 0.546 0.550 0.510 0.501 0.032 0.024 0.009 0.021 0.024)))
(snd-display ";elliptic bp 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-bandpass 6 .1 .2 .1 90))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-bandpass 6 .1 .2 .1 90))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bp 6 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.002 0.511 0.532 0.503 0.492 0.003 0.001 0.001 0.001 0.001)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.002 0.511 0.532 0.503 0.492 0.003 0.001 0.001 0.001 0.001)))
(snd-display ";elliptic bp 6 .1 .2 90 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-bandstop 4 .1 .3 .1))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-bandstop 4 .1 .3 .1))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bs 4 max: ~A" (car vals)))
- (if (not (vequal1 (cadr vals) (float-vector 0.499 0.502 0.498 0.037 0.050 0.540 0.544 0.527 0.526 0.521)))
+ (if (not (mus-arrays-equal?1 (cadr vals) (float-vector 0.499 0.502 0.498 0.037 0.050 0.540 0.544 0.527 0.526 0.521)))
(snd-display ";elliptic bs 4 .1 .2 spect: ~A" (cadr vals))))
- (let* ((f1 (make-elliptic-bandstop 8 .1 .3 .1 120))
- (vals (sweep->bins f1)))
+ (let ((vals (sweep->bins (make-elliptic-bandstop 8 .1 .3 .1 120))))
(if (> (abs (- (car vals) .5)) .1) (snd-display ";elliptic bs 8 max: ~A" (car vals)))
- (if (not (or (vequal1 (cadr vals) (float-vector 0.500 0.499 0.476 0.000 0.000 0.495 0.526 0.505 0.501 0.501))
- (vequal1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.495 0.526 0.505 0.501 0.501))))
+ (if (not (or (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.499 0.476 0.000 0.000 0.495 0.526 0.505 0.501 0.501))
+ (mus-arrays-equal?1 (cadr vals) (float-vector 0.500 0.499 0.475 0.000 0.000 0.495 0.526 0.505 0.501 0.501))))
(snd-display ";elliptic bs 8 .1 .2 spect: ~A" (cadr vals))))
)))
@@ -10957,89 +10830,89 @@ EDITS: 2
;; degree 0 + x=0
(let ((val (poly-roots (float-vector 0.0 1.0))))
- (if (not (ceql val (list 0.0))) (snd-display ";poly-roots 0.0 1.0: ~A" val)))
+ (if (not (ceql val '(0.0))) (snd-display ";poly-roots 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector 0.0 0.0 0.0 121.0))))
- (if (not (ceql val (list 0.0 0.0 0.0))) (snd-display ";poly-roots 0.0 0.0 0.0 121.0: ~A" val)))
+ (if (not (ceql val '(0.0 0.0 0.0))) (snd-display ";poly-roots 0.0 0.0 0.0 121.0: ~A" val)))
;; degree=1
(let ((val (poly-roots (float-vector -1.0 1.0))))
- (if (not (ceql val (list 1.0))) (snd-display ";poly-roots -1.0 1.0: ~A" val)))
+ (if (not (ceql val '(1.0))) (snd-display ";poly-roots -1.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector -2.0 4.0))))
- (if (not (ceql val (list 0.5))) (snd-display ";poly-roots -2.0 4.0: ~A" val)))
+ (if (not (ceql val '(0.5))) (snd-display ";poly-roots -2.0 4.0: ~A" val)))
(let ((val (poly-as-vector-roots (vector 0.0-i 1))))
- (if (not (ceql val (list -0.0+1.0i))) (snd-display ";poly-roots: -i 1: ~A" val)))
+ (if (not (ceql val '(-0.0+1.0i))) (snd-display ";poly-roots: -i 1: ~A" val)))
;; linear x^n
(let ((val (poly-roots (float-vector -1.0 0.0 0.0 0.0 1.0))))
- (if (not (or (ceql val (list 0.0-1.0i -1.0 0.0+1.0i 1.0))
- (ceql val (list 1.0 -1.0 0.0+1.0i -0.0-1.0i))))
+ (if (not (or (ceql val '(0.0-1.0i -1.0 0.0+1.0i 1.0))
+ (ceql val '(1.0 -1.0 0.0+1.0i -0.0-1.0i))))
(snd-display ";poly-roots -1.0 0.0 0.0 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector -16.0 0.0 0.0 0.0 1.0))))
- (if (not (or (ceql val (list 0.0-2.0i -2.0 0.0+2.0i 2.0))
- (ceql val (list 2.0 -2.0 0.0+2.0i -0.0-2.0i))))
+ (if (not (or (ceql val '(0.0-2.0i -2.0 0.0+2.0i 2.0))
+ (ceql val '(2.0 -2.0 0.0+2.0i -0.0-2.0i))))
(snd-display ";poly-roots -16.0 0.0 0.0 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector -32.0 0 0 0 0 0 0.5))))
- (if (not (ceql val (list 1.0-1.7320i -1.0-1.7320i -2.0 -1.0+1.7320i 1.0+1.7320i 2.0))) (snd-display ";poly-roots 32 0 0 0 0 0 0.5: ~A" val)))
+ (if (not (ceql val '(1.0-1.7320i -1.0-1.7320i -2.0 -1.0+1.7320i 1.0+1.7320i 2.0))) (snd-display ";poly-roots 32 0 0 0 0 0 0.5: ~A" val)))
;; linear + x=0
(let ((val (poly-roots (float-vector 0.0 -2.0 4.0))))
- (if (not (ceql val (list 0.0 0.5))) (snd-display ";poly-roots 0.0 -2.0 4.0: ~A" val)))
+ (if (not (ceql val '(0.0 0.5))) (snd-display ";poly-roots 0.0 -2.0 4.0: ~A" val)))
;; degree=2
(let ((val (poly-roots (float-vector -1.0 0.0 1.0))))
- (if (not (ceql val (list 1.0 -1.0))) (snd-display ";poly-roots -1.0 0.0 1.0: ~A" val)))
+ (if (not (ceql val '(1.0 -1.0))) (snd-display ";poly-roots -1.0 0.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector 15.0 -8.0 1.0))))
- (if (not (ceql val (list 5.0 3.0))) (snd-display ";poly-roots 15.0 -8.0 1.0: ~A" val)))
+ (if (not (ceql val '(5.0 3.0))) (snd-display ";poly-roots 15.0 -8.0 1.0: ~A" val)))
(let ((val (poly-roots (float-vector 1 -2 1))))
- (if (not (ceql val (list 1.0 1.0))) (snd-display ";poly-roots 1 -2 1: ~A" val)))
+ (if (not (ceql val '(1.0 1.0))) (snd-display ";poly-roots 1 -2 1: ~A" val)))
(let ((val (poly-as-vector-roots (vector -1 0.0+2i 1))))
- (if (not (ceql val (list 0.0-1.0i 0.0-1.0i))) (snd-display ";poly-roots -1 2i 1: ~A" val)))
+ (if (not (ceql val '(0.0-1.0i 0.0-1.0i))) (snd-display ";poly-roots -1 2i 1: ~A" val)))
(let ((val (poly-roots (float-vector 1 1 5))))
- (if (not (ceql val (list -0.1+0.43589i -0.1-0.43589i))) (snd-display ";poly-roots 1 1 5: ~A" val)))
+ (if (not (ceql val '(-0.1+0.43589i -0.1-0.43589i))) (snd-display ";poly-roots 1 1 5: ~A" val)))
;; 2 + x=0
(let ((val (poly-roots (float-vector 0.0 0.0 -1.0 0.0 1.0))))
- (if (not (ceql val (list 0.0 0.0 1.0 -1.0))) (snd-display ";poly-roots 0.0 0.0 -1.0 0.0 1.0: ~A" val)))
+ (if (not (ceql val '(0.0 0.0 1.0 -1.0))) (snd-display ";poly-roots 0.0 0.0 -1.0 0.0 1.0: ~A" val)))
;; quadratic in x^(n/2)
(let ((vals (poly-roots (float-vector 1.0 0.0 -2.0 0.0 1.0))))
- (if (not (or (ceql vals (list -1.0 1.0 -1.0 1.0))
- (ceql vals (list 1.0 1.0 -1.0 -1.0))))
+ (if (not (or (ceql vals '(-1.0 1.0 -1.0 1.0))
+ (ceql vals '(1.0 1.0 -1.0 -1.0))))
(snd-display ";poly-roots 1 0 -2 0 1: ~A" vals)))
(let ((vals (poly-roots (float-vector 64.0 0.0 0.0 -16.0 0.0 0.0 1.0))))
- (if (not (ceql vals (list -1.0-1.73205i -1.0+1.73205i 2.0 -1.0-1.73205i -1.0+1.73205i 2.0)))
+ (if (not (ceql vals '(-1.0-1.73205i -1.0+1.73205i 2.0 -1.0-1.73205i -1.0+1.73205i 2.0)))
(snd-display ";poly-roots 64 0 0 -16 0 0 1: ~A" vals)))
;; degree=3
(let ((val (poly-roots (float-vector -15.0 23.0 -9.0 1.0))))
- (if (not (ceql val (list 5.0 1.0 3.0))) (snd-display ";poly-roots 5 1 3: ~A" val)))
+ (if (not (ceql val '(5.0 1.0 3.0))) (snd-display ";poly-roots 5 1 3: ~A" val)))
(let ((val (poly-roots (float-vector -126 -15 0 1))))
- (if (not (ceql val (list 6.0 -3.0+3.46410i -3.0-3.46410i))) (snd-display ";poly-roots -126 -15 0 1: ~A" val)))
+ (if (not (ceql val '(6.0 -3.0+3.46410i -3.0-3.46410i))) (snd-display ";poly-roots -126 -15 0 1: ~A" val)))
(let ((val (poly-roots (float-vector -1 3 -3 1))))
- (if (not (ceql val (list 1.0 1.0 1.0))) (snd-display ";poly-roots -1 3 -3 1: ~A" val)))
+ (if (not (ceql val '(1.0 1.0 1.0))) (snd-display ";poly-roots -1 3 -3 1: ~A" val)))
(let ((val (poly-roots (float-vector 1 -1 -1 1))))
- (if (not (or (ceql val (list 1.0 -1.0 1.0))
- (ceql val (list -1.0 1.0 1.0))))
+ (if (not (or (ceql val '(1.0 -1.0 1.0))
+ (ceql val '(-1.0 1.0 1.0))))
(snd-display ";poly-roots 1 -1 1: ~A" val)))
(let ((val (poly-roots (float-vector 2 -2 -2 2))))
- (if (not (or (ceql val (list 1.0 -1.0 1.0))
- (ceql val (list -1.0 1.0 1.0))))
+ (if (not (or (ceql val '(1.0 -1.0 1.0))
+ (ceql val '(-1.0 1.0 1.0))))
(snd-display ";poly-roots 2 -2 -2 2: ~A" val)))
;; degree=4
; (let ((vals (poly-roots (float-vector -15 8 14 -8 1))))
- ; (if (not (ceql vals (list 5.0 3.0 1.0 -1.0))) (snd-display ";poly-roots -15 8 14 -8 1: ~A" vals)))
+ ; (if (not (ceql vals '(5.0 3.0 1.0 -1.0))) (snd-display ";poly-roots -15 8 14 -8 1: ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector 8 1) (float-vector -9 1)))))))
- ; (if (not (ceql vals (list 9.0 3.0 -2.0 -8.0))) (snd-display ";poly-roots 4(1): ~A" vals)))
+ ; (if (not (ceql vals '(9.0 3.0 -2.0 -8.0))) (snd-display ";poly-roots 4(1): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (poly* (float-vector .2 1) (float-vector -3 1)) (poly* (float-vector .8 1) (float-vector -9 1)))))))
- ; (if (not (ceql vals (list 9.0 3.0 -0.2 -0.8))) (snd-display ";poly-roots 4(2): ~A" vals)))
+ ; (if (not (ceql vals '(9.0 3.0 -0.2 -0.8))) (snd-display ";poly-roots 4(2): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (poly* (float-vector .02 1) (float-vector -32 1)) (poly* (float-vector .8 1) (float-vector -9 1)))))))
- ; (if (not (ceql vals (list 32.0 9.0 -0.02 -0.8))) (snd-display ";poly-roots 4(3): ~A" vals)))
+ ; (if (not (ceql vals '(32.0 9.0 -0.02 -0.8))) (snd-display ";poly-roots 4(3): ~A" vals)))
;; degree>4
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector -1 1) (float-vector -2 1))))))))
- ; (if (not (ceql vals (list 3.0 2.0 -1.0 -2.0 1.0)))
+ ; (if (not (ceql vals '(3.0 2.0 -1.0 -2.0 1.0)))
; (snd-display ";poly-roots n(1): ~A from ~A ~A ~A"
; vals
; (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector -1 1) (float-vector -2 1)))))
@@ -11047,27 +10920,27 @@ EDITS: 2
; poly-roots-epsilon)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector 8 1) (float-vector -9 1))))))))
- ; (if (not (ceql vals (list 9.0 3.0 -2.0 -8.0 -1.0))) (snd-display ";poly-roots n(2): ~A" vals)))
+ ; (if (not (ceql vals '(9.0 3.0 -2.0 -8.0 -1.0))) (snd-display ";poly-roots n(2): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector -1 0 1) (poly* (poly* (float-vector 9 1) (float-vector -3 1)) (poly* (float-vector -10 1) (float-vector -2 1))))))))
- ; (if (not (ceql vals (list 10.0 3.0 -1.0 -9.0 2.0 1.0))) (snd-display ";poly-roots n(3): ~A" vals)))
+ ; (if (not (ceql vals '(10.0 3.0 -1.0 -9.0 2.0 1.0))) (snd-display ";poly-roots n(3): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector -1 0 1) (poly* (poly* (float-vector -4 0 1) (float-vector -3 1)) (poly* (float-vector -10 1) (float-vector -9 0 1))))))))
- ; (if (not (ceql vals (list 10.0 3.0 -2.0 -3.0 -1.0 3.0 2.0 1.0))) (snd-display ";poly-roots n(4): ~A" vals)))
+ ; (if (not (ceql vals '(10.0 3.0 -2.0 -3.0 -1.0 3.0 2.0 1.0))) (snd-display ";poly-roots n(4): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector -1 0 1) (poly* (poly* (float-vector -4 0 1) (float-vector -16 0 1)) (poly* (float-vector -25 0 1) (float-vector -9 0 1))))))))
- ; (if (not (ceql vals (list 5.0 -3.0 -4.0 -5.0 4.0 -2.0 3.0 -1.0 2.0 1.0))) (snd-display ";poly-roots n(5): ~A" vals)))
+ ; (if (not (ceql vals '(5.0 -3.0 -4.0 -5.0 4.0 -2.0 3.0 -1.0 2.0 1.0))) (snd-display ";poly-roots n(5): ~A" vals)))
; (let ((vals (poly-roots (poly-reduce (poly* (float-vector 1 1) (poly* (poly* (float-vector 2 1) (float-vector -3 1)) (poly* (float-vector 1 1) (float-vector -2 1))))))))
- ; (if (not (ceql vals (list 3.0 -1.0 -1.0 -2.0 2.0))) (snd-display ";poly-roots n(6): ~A" vals)))
+ ; (if (not (ceql vals '(3.0 -1.0 -1.0 -2.0 2.0))) (snd-display ";poly-roots n(6): ~A" vals)))
(let ((vals (poly-roots (float-vector -64 0 0 0 0 0 1))))
- (if (not (ceql vals (list 0.999999999999999-1.73205080756888i -1.0-1.73205080756888i -2.0 -1.0+1.73205080756888i 1.0+1.73205080756888i 2.0)))
+ (if (not (ceql vals '(0.999999999999999-1.73205080756888i -1.0-1.73205080756888i -2.0 -1.0+1.73205080756888i 1.0+1.73205080756888i 2.0)))
(snd-display ";poly-roots 64 6: ~A" vals)))
(let ((vals (poly-roots (float-vector 64 0 0 -16 0 0 1))))
- (if (not (ceql vals (list -1.0-1.73205080756888i -1.0+1.73205080756888i 2.0 -1.0-1.73205080756888i -1.0+1.73205080756888i 2.0)))
+ (if (not (ceql vals '(-1.0-1.73205080756888i -1.0+1.73205080756888i 2.0 -1.0-1.73205080756888i -1.0+1.73205080756888i 2.0)))
(snd-display ";poly-roots 64 16 6: ~A" vals)))
(do ((i 0 (+ i 1))) ((= i 10)) (poly-roots (float-vector (random 1.0) (random 1.0) (random 1.0))))
(do ((i 0 (+ i 1))) ((= i 10)) (poly-roots (float-vector (mus-random 1.0) (mus-random 1.0) (mus-random 1.0))))
(let ((vals1 (convolution (float-vector 1 2 3 0 0 0 0 0) (float-vector 1 2 3 0 0 0 0 0) 8))
(vals2 (poly* (float-vector 1 2 3 0) (float-vector 1 2 3 0))))
- (if (not (vequal vals1 vals2))
+ (if (not (mus-arrays-equal? vals1 vals2))
(snd-display ";poly* convolve: ~A ~A" vals1 vals2)))
@@ -11089,38 +10962,38 @@ EDITS: 2
(complex (mus-random 1.0) (mus-random 1.0)))))
(do ((i 3 (+ i 1))) ((= i 20))
- (let ((v (make-float-vector i 0.0)))
+ (let ((v (make-float-vector i)))
(set! (v 0) (mus-random 1.0))
(set! (v (- i 1)) 1.0)
(poly-roots v)))
(do ((i 3 (+ i 2))) ((= i 21))
- (let ((v (make-float-vector i 0.0)))
+ (let ((v (make-float-vector i)))
(set! (v 0) (mus-random 1.0))
(set! (v (- i 1)) 1.0)
(set! (v (/ (- i 1) 2)) 1.0)
(poly-roots v)))
(let ((vals (poly-roots (float-vector 1 -1 -1 1))))
- (if (not (or (ceql vals (list 1.0 -1.0 1.0))
- (ceql vals (list -1.0 1.0 1.0))))
+ (if (not (or (ceql vals '(1.0 -1.0 1.0))
+ (ceql vals '(-1.0 1.0 1.0))))
(snd-display ";poly-roots 1-1-11: ~A" vals)))
(let ((vals (poly-roots (float-vector 2 -1 -2 1))))
- (if (not (ceql vals (list 2.0 -1.0 1.0))) (snd-display ";poly-roots 2-1-21: ~A" vals)))
+ (if (not (ceql vals '(2.0 -1.0 1.0))) (snd-display ";poly-roots 2-1-21: ~A" vals)))
(let ((vals (poly-roots (float-vector -1 1 1 1))))
- (if (not (ceql vals (list 0.543689012692076 -0.771844506346038+1.11514250803994i -0.771844506346038-1.11514250803994i)))
+ (if (not (ceql vals '(0.543689012692076 -0.771844506346038+1.11514250803994i -0.771844506346038-1.11514250803994i)))
(snd-display ";poly-roots -1111: ~A" vals)))
(let ((vals (poly-roots (float-vector -1 3 -3 1))))
- (if (not (ceql vals (list 1.0 1.0 1.0))) (snd-display ";poly-roots -13-31: ~A" vals)))
+ (if (not (ceql vals '(1.0 1.0 1.0))) (snd-display ";poly-roots -13-31: ~A" vals)))
; (let ((vals (poly-roots (float-vector 1 -4 6 -4 1))))
- ; (if (not (ceql vals (list 1.0 1.0 1.0 1.0))) (snd-display ";poly-roots 1-46-41: ~A" vals)))
+ ; (if (not (ceql vals '(1.0 1.0 1.0 1.0))) (snd-display ";poly-roots 1-46-41: ~A" vals)))
(let ((vals (poly-roots (float-vector 0.5 0 0 1.0))))
- (if (not (or (ceql vals (list 0.396850262992049-0.687364818499302i -0.7937005259841 0.39685026299205+0.687364818499301i))
- (ceql vals (list 0.39685026299205+0.687364818499301i 0.39685026299205-0.687364818499301i -0.7937005259841))
- (ceql vals (list -7.9370052598409979172089E-1 3.968502629920498958E-1+6.873648184993013E-1i 3.96850262992049E-1-6.873648184993E-1i))))
+ (if (not (or (ceql vals '(0.396850262992049-0.687364818499302i -0.7937005259841 0.39685026299205+0.687364818499301i))
+ (ceql vals '(0.39685026299205+0.687364818499301i 0.39685026299205-0.687364818499301i -0.7937005259841))
+ (ceql vals '(-7.9370052598409979172089E-1 3.968502629920498958E-1+6.873648184993013E-1i 3.96850262992049E-1-6.873648184993E-1i))))
(snd-display ";poly-roots 0..5 3: ~A" vals)))
(let ((vals (poly-roots (poly* (poly* (poly* (float-vector -1 1) (float-vector 1 1)) (poly* (float-vector -2 1) (float-vector 2 1))) (poly* (float-vector -3 1) (float-vector 3 1))))))
- (if (not (ceql vals (list -3.0 3.0 -1.0 1.0 -2.0 2.0)))
+ (if (not (ceql vals '(-3.0 3.0 -1.0 1.0 -2.0 2.0)))
(snd-display ";cube in 2: ~A" vals)))
))
@@ -11192,16 +11065,11 @@ EDITS: 2
;; ----------------
(define* (ssb-am-1 gen y (fm-1 0.0))
- (let* ((fm fm-1)
- (ccos (oscil (gen 'coscar) fm))
- (csin (oscil (gen 'sincar) fm))
- (yh (hilbert-transform (gen 'hlb) y))
- (yd (delay (gen 'dly) y)))
- (if (> (gen 'freq) 0.0)
- (- (* ccos yd) ; shift up
- (* csin yh))
- (+ (* ccos yd) ; shift down
- (* csin yh)))))
+ (let* ((ccos (oscil (gen 'coscar) fm-1))
+ (csin (oscil (gen 'sincar) fm-1)))
+ ((if (> (gen 'freq) 0.0) - +)
+ (* ccos (delay (gen 'dly) y))
+ (* csin (hilbert-transform (gen 'hlb) y)))))
;; ----------------
@@ -11260,10 +11128,10 @@ EDITS: 2
(snd-display ";run ~A equal?~% ~A~% ~A" (mus-name g0) g0 g2))
(let ((data (catch #t (lambda () (mus-data g0)) (lambda args #f))))
(when (float-vector? data)
- (let ((g4 (copy g0)))
- (let ((data4 (catch #t (lambda () (mus-data g4)) (lambda args #f))))
- (if (not (float-vector? data4))
- (snd-display ";~A copy -> mus-data ~A?" (mus-name g0) data4))))))))
+ (let* ((g4 (copy g0))
+ (data4 (catch #t (lambda () (mus-data g4)) (lambda args #f))))
+ (if (not (float-vector? data4))
+ (snd-display ";~A copy -> mus-data ~A?" (mus-name g0) data4)))))))
;; ----------------
(define (fm-test gen)
@@ -11285,7 +11153,7 @@ EDITS: 2
(gen 1.0)
(if (fneq (mus-phase gen) 6.0) (snd-display ";~A phase(3, 2, 1): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
(do ((i 0 (+ i 1))) ((= i 10)) (gen 10.0))
- (if (fneq (mus-phase gen) (+ 26 (- 100 (* 40 pi)))) ;(+ 26 (- 100 (* 2 pi 20)))
+ (if (fneq (mus-phase gen) (- 126 (* 40 pi))) ;(+ 26 (- 100 (* 40 pi)))) ;(+ 26 (- 100 (* 2 pi 20)))
(snd-display ";~A phase (over): ~A ~A" gen (mus-phase gen) (mus-frequency gen)))
(set! (mus-frequency gen) 0.0)
(set! (mus-phase gen) 0.0)
@@ -11305,8 +11173,7 @@ EDITS: 2
(map-channel
(lambda (y)
(let* ((curmax (moving-max maxer y))
- (diff (- 0.5 (* mult curmax)))
- (this-incr (* diff ramp-speed)))
+ (this-incr (* (- 0.5 (* mult curmax)) ramp-speed)))
(set! mult (+ mult this-incr))
(* y mult))))))
@@ -11333,9 +11200,8 @@ EDITS: 2
(max-bad 0.0))
(do ((i 0 (+ i 1)))
((= i 15))
- (let* ((nval (acosh (vector-ref args i)))
- (diff (abs (- nval (vector-ref vals i)))))
- (set! max-bad (max max-bad diff))))
+ (let ((nval (acosh (vector-ref args i))))
+ (set! max-bad (max max-bad (abs (- nval (vector-ref vals i)))))))
(if (> max-bad 1.0e-15)
(snd-display ";acosh: ~A" max-bad)))
@@ -11652,8 +11518,8 @@ EDITS: 2
(sv (expt x pow)))
(if (fneq lv sv)
(snd-display ";~A ^ ~A = ~A ~A?" x pow lv sv))))
- (list 0 1 2 3 4 5 6)))
- (list 2.0 0.5 0.1 -0.5 3.0 0.8)))
+ '(0 1 2 3 4 5 6)))
+ '(2.0 0.5 0.1 -0.5 3.0 0.8)))
(let* ((snd (with-sound (:scaled-to 0.5)
(do ((i 0 (+ i 1))
@@ -11734,8 +11600,8 @@ EDITS: 2
(numerical-reality-checks)
(if (mus-generator? 321) (snd-display ";123 is a gen?"))
- (if (mus-generator? (list 321)) (snd-display ";(123) is a gen?"))
- (if (mus-generator? (list 'hi 321)) (snd-display ";(hi 123) is a gen?"))
+ (if (mus-generator? '(321)) (snd-display ";(123) is a gen?"))
+ (if (mus-generator? '(hi 321)) (snd-display ";(hi 123) is a gen?"))
(set! *clm-srate* 22050)
(let ((samps (seconds->samples 1.0))
(secs (samples->seconds 22050)))
@@ -11826,67 +11692,67 @@ EDITS: 2
(if (not (fveql lv3 '(1.000 2.000 -8.000 0.000 16.000 0.000) 0)) (snd-display ";partials->polynomial(4): ~A?" lv3)))
(let ((lv4 (partials->polynomial '(1 1 2 .5 3 .1 6 .01) mus-chebyshev-first-kind)))
(if (not (fveql lv4 '(-0.510 0.700 1.180 0.400 -0.480 0.000 0.320) 0)) (snd-display ";partials->polynomial(5): ~A?" lv4)))
- (let ((lv5 (partials->polynomial (list 1 1 2 .5 3 .1 6 .01) mus-chebyshev-second-kind)))
+ (let ((lv5 (partials->polynomial '(1 1 2 .5 3 .1 6 .01) mus-chebyshev-second-kind)))
(if (not (fveql lv5 '(0.900 1.060 0.400 -0.320 0.000 0.320 0.000) 0)) (snd-display ";partials->polynomial(6): ~A?" lv5)))
(let ((lv6 (partials->polynomial (float-vector 1 9 2 3 3 5 4 7 5 1))))
- (if (not (vequal lv6 (float-vector 4.000 -1.000 -50.000 0.000 56.000 16.000))) (snd-display ";partials->polynomial(7): ~A?" lv6)))
+ (if (not (mus-arrays-equal? lv6 (float-vector 4.000 -1.000 -50.000 0.000 56.000 16.000))) (snd-display ";partials->polynomial(7): ~A?" lv6)))
(let ((lv7 (partials->polynomial '(7 1))))
- (if (not (vequal lv7 (float-vector 0.000 -7.000 0.000 56.000 0.000 -112.000 0.000 64.000))) (snd-display ";partials->polynomial(8): ~A?" lv7))
+ (if (not (mus-arrays-equal? lv7 (float-vector 0.000 -7.000 0.000 56.000 0.000 -112.000 0.000 64.000))) (snd-display ";partials->polynomial(8): ~A?" lv7))
(let ((lv7a (partials->polynomial '(7 1) mus-chebyshev-first-kind)))
- (if (not (vequal lv7 lv7a)) (snd-display ";partials->polynomial kind=1? ~A ~A" lv7 lv7a)))
+ (if (not (mus-arrays-equal? lv7 lv7a)) (snd-display ";partials->polynomial kind=1? ~A ~A" lv7 lv7a)))
(if (fneq (polynomial lv7 1.0) (cosh (* 7 (acosh 1.0))))
(snd-display ";ccosh cheb 7 1.0: ~A ~A" (polynomial lv7 1.0) (cosh (* 7 (acosh 1.0)))))
(if (fneq (polynomial lv7 1.0) (cos (* 7 (acos 1.0))))
(snd-display ";cos cheb 7 1.0: ~A ~A" (polynomial lv7 1.0) (cos (* 7 (acos 1.0)))))
- (let ((lv8 (partials->polynomial '(7 1) mus-chebyshev-second-kind)))
- (do ((sa (sin (acos 0.5)))
- (ca (acos 0.5))
- (i 0 (+ i 1)))
- ((= i 10))
- (let* ((val (mus-random 1.0))
- (aval (acos val)))
- (if (fneq (polynomial lv7 val) (cosh (* 7 (acosh val))))
- (snd-display ";ccosh cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cosh (* 7 (acosh val)))))
- (if (fneq (polynomial lv7 val) (cos (* 7 aval)))
- (snd-display ";cos cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cos (* 7 aval))))
- (if (fneq (polynomial lv8 val) (/ (sin (* 7 aval)) (sin aval)))
- (snd-display ";acos cheb 7 ~A: ~A ~A" val (polynomial lv8 val) (/ (sin (* 7 aval)) (sin aval)))))
- (if (not (vequal lv8 (float-vector -1.000 0.000 24.000 0.000 -80.000 0.000 64.000 0.000))) (snd-display ";partials->polynomial(9): ~A?" lv8))
- (if (fneq (polynomial lv8 0.5) (/ (sin (* 7 ca)) sa))
- (snd-display ";acos cheb 7 1.0: ~A ~A" (polynomial lv8 0.5) (/ (sin (* 7 ca)) sa))))))
+ (do ((lv8 (partials->polynomial '(7 1) mus-chebyshev-second-kind))
+ (sa (sin (acos 0.5)))
+ (ca (acos 0.5))
+ (i 0 (+ i 1)))
+ ((= i 10))
+ (let* ((val (mus-random 1.0))
+ (aval (acos val)))
+ (if (fneq (polynomial lv7 val) (cosh (* 7 (acosh val))))
+ (snd-display ";ccosh cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cosh (* 7 (acosh val)))))
+ (if (fneq (polynomial lv7 val) (cos (* 7 aval)))
+ (snd-display ";cos cheb 7 ~A: ~A ~A" val (polynomial lv7 val) (cos (* 7 aval))))
+ (if (fneq (polynomial lv8 val) (/ (sin (* 7 aval)) (sin aval)))
+ (snd-display ";acos cheb 7 ~A: ~A ~A" val (polynomial lv8 val) (/ (sin (* 7 aval)) (sin aval)))))
+ (if (not (mus-arrays-equal? lv8 (float-vector -1.000 0.000 24.000 0.000 -80.000 0.000 64.000 0.000))) (snd-display ";partials->polynomial(9): ~A?" lv8))
+ (if (fneq (polynomial lv8 0.5) (/ (sin (* 7 ca)) sa))
+ (snd-display ";acos cheb 7 1.0: ~A ~A" (polynomial lv8 0.5) (/ (sin (* 7 ca)) sa)))))
;; G&R 8.943 p 984 uses n+1 where we use n in Un? (our numbering keeps harmonics aligned between Tn and Un)
- (if (not (vequal (normalize-partials (list 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
+ (if (not (mus-arrays-equal? (normalize-partials (list 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
(snd-display ";normalize-partials 1: ~A" (normalize-partials (list 1 1 2 1))))
- (if (not (vequal (normalize-partials (float-vector 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
+ (if (not (mus-arrays-equal? (normalize-partials (float-vector 1 1 2 1)) (float-vector 1.000 0.500 2.000 0.500)))
(snd-display ";normalize-partials 2: ~A" (normalize-partials (float-vector 1 1 2 1))))
- (if (not (vequal (normalize-partials (float-vector 1 1 2 -1)) (float-vector 1.000 0.500 2.000 -0.500)))
+ (if (not (mus-arrays-equal? (normalize-partials (float-vector 1 1 2 -1)) (float-vector 1.000 0.500 2.000 -0.500)))
(snd-display ";normalize-partials 3: ~A" (normalize-partials (float-vector 1 1 2 -1))))
- (if (not (vequal (normalize-partials (float-vector 1 -.1 2 -.1)) (float-vector 1.000 -0.500 2.000 -0.500)))
+ (if (not (mus-arrays-equal? (normalize-partials (float-vector 1 -.1 2 -.1)) (float-vector 1.000 -0.500 2.000 -0.500)))
(snd-display ";normalize-partials 4: ~A" (normalize-partials (float-vector 1 -.1 2 -.1))))
- (if (not (vequal (normalize-partials (float-vector 0 2 1 1 4 1)) (float-vector 0.000 0.500 1.000 0.250 4.000 0.250)))
+ (if (not (mus-arrays-equal? (normalize-partials (float-vector 0 2 1 1 4 1)) (float-vector 0.000 0.500 1.000 0.250 4.000 0.250)))
(snd-display ";normalize-partials 4: ~A" (normalize-partials (float-vector 0 2 1 1 4 1))))
;; check phase-quadrature cancellations
- (let ((cos-coeffs (partials->polynomial '(1 1 2 1) mus-chebyshev-first-kind))
- (sin-coeffs (partials->polynomial (float-vector 1 1 2 1) mus-chebyshev-second-kind))
- (incr (/ (* 2 pi 440.0) 22050.0)))
- (do ((i 0 (+ i 1))
- (a 0.0 (+ a incr)))
- ((= i 1100))
- (let* ((x (cos a))
- (y (sin a))
- (cax (polynomial cos-coeffs x))
- (sax (polynomial sin-coeffs x))
- (upper (- (* (cos (* 2 a)) cax) (* (sin (* 2 a)) y sax)))
- (lower (+ (* (cos (* 2 a)) cax) (* (sin (* 2 a)) y sax)))
- (upper2 (+ (cos (* a 3)) (cos (* a 4))))
- (lower2 (+ 1.0 (cos a))))
- (if (or (fneq upper upper2)
- (fneq lower lower2))
- (snd-display ";~A ~A, ~A ~A" upper upper2 lower lower2)))))
-
- (let ((tag (catch #t (lambda () (harmonicizer 550.0 (list .5 .3 .2) 10)) (lambda args (car args)))))
+ (do ((cos-coeffs (partials->polynomial '(1 1 2 1) mus-chebyshev-first-kind))
+ (sin-coeffs (partials->polynomial (float-vector 1 1 2 1) mus-chebyshev-second-kind))
+ (incr (/ (* 2 pi 440.0) 22050.0))
+ (i 0 (+ i 1))
+ (a 0.0 (+ a incr)))
+ ((= i 1100))
+ (let* ((x (cos a))
+ (y (sin a))
+ (cax (polynomial cos-coeffs x))
+ (sax (polynomial sin-coeffs x))
+ (upper (- (* (cos (* 2 a)) cax) (* (sin (* 2 a)) y sax)))
+ (lower (+ (* (cos (* 2 a)) cax) (* (sin (* 2 a)) y sax)))
+ (upper2 (+ (cos (* a 3)) (cos (* a 4))))
+ (lower2 (+ 1.0 (cos a))))
+ (if (or (fneq upper upper2)
+ (fneq lower lower2))
+ (snd-display ";~A ~A, ~A ~A" upper upper2 lower lower2))))
+
+ (let ((tag (catch #t (lambda () (harmonicizer 550.0 '(.5 .3 .2) 10)) (lambda args (car args)))))
(if (not (eq? tag 'no-data)) (snd-display ";odd length arg to partials->polynomial: ~A" tag)))
(let ((rdat (make-float-vector 16))
@@ -11995,7 +11861,7 @@ EDITS: 2
(v1 (make-float-vector 8)))
(do ((i 0 (+ i 1))) ((= i 8)) (set! (v0 i) i) (set! (v1 i) (/ (+ i 1))))
(rectangular->magnitudes v0 v1)
- (if (not (vequal v0 (float-vector 1.000 1.118 2.028 3.010 4.005 5.003 6.002 7.001)))
+ (if (not (mus-arrays-equal? v0 (float-vector 1.000 1.118 2.028 3.010 4.005 5.003 6.002 7.001)))
(snd-display ";rectangular->magnitudes v0: ~A" v0)))
(let ((v0 (make-float-vector 8))
@@ -12012,7 +11878,7 @@ EDITS: 2
(float-vector-set! v3 i val2)))
(rectangular->magnitudes v0 v1)
(rectangular->polar v2 v3)
- (if (not (vequal v0 v2))
+ (if (not (mus-arrays-equal? v0 v2))
(snd-display ";rectangular->magnitudes|polar: ~A ~A" v0 v2)))
(when (defined? 'edot-product) ; needs complex numbers in C
@@ -12106,70 +11972,70 @@ EDITS: 2
(if (> err 1.1e-7) (snd-display ";new-cos poly err: ~A" err))))
(let ((val (poly+ (float-vector .1 .2 .3) (float-vector 0.0 1.0 2.0 3.0 4.0))))
- (if (not (vequal val (float-vector 0.100 1.200 2.300 3.000 4.000))) (snd-display ";poly+ 1: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 0.100 1.200 2.300 3.000 4.000))) (snd-display ";poly+ 1: ~A" val)))
(let ((val (poly+ (float-vector .1 .2 .3) .5)))
- (if (not (vequal val (float-vector 0.600 0.200 0.300))) (snd-display ";poly+ 2: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 0.600 0.200 0.300))) (snd-display ";poly+ 2: ~A" val)))
(let ((val (poly+ .5 (float-vector .1 .2 .3))))
- (if (not (vequal val (float-vector 0.600 0.200 0.300))) (snd-display ";poly+ 3: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 0.600 0.200 0.300))) (snd-display ";poly+ 3: ~A" val)))
(let ((val (poly* (float-vector 1 1) (float-vector -1 1))))
- (if (not (vequal val (float-vector -1.000 0.000 1.000 0.000))) (snd-display ";poly* 1: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector -1.000 0.000 1.000 0.000))) (snd-display ";poly* 1: ~A" val)))
(let ((val (poly* (float-vector -5 1) (float-vector 3 7 2))))
- (if (not (vequal val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display ";poly* 2: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display ";poly* 2: ~A" val)))
(let ((val (poly* (float-vector -30 -4 2) (float-vector 0.5 1))))
- (if (not (vequal val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display ";poly* 3: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector -15.000 -32.000 -3.000 2.000 0.000))) (snd-display ";poly* 3: ~A" val)))
(let ((val (poly* (float-vector -30 -4 2) 0.5)))
- (if (not (vequal val (float-vector -15.000 -2.000 1.000))) (snd-display ";poly* 4: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector -15.000 -2.000 1.000))) (snd-display ";poly* 4: ~A" val)))
(let ((val (poly* 2.0 (float-vector -30 -4 2))))
- (if (not (vequal val (float-vector -60.000 -8.000 4.000))) (snd-display ";poly* 5: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector -60.000 -8.000 4.000))) (snd-display ";poly* 5: ~A" val)))
(let ((val (poly/ (float-vector -1.0 -0.0 1.0) (float-vector 1.0 1.0))))
- (if (not (and (vequal (car val) (float-vector -1.000 1.000 0.000))
- (vequal (cadr val) (float-vector 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -1.000 1.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 0.000 0.000 0.000))))
(snd-display ";poly/ 1: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector -5 1))))
- (if (not (and (vequal (car val) (float-vector 3.000 7.000 2.000 0.000))
- (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector 3.000 7.000 2.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
(snd-display ";poly/ 2: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector 3 1))))
- (if (not (and (vequal (car val) (float-vector -5.000 -9.000 2.000 0.000))
- (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -5.000 -9.000 2.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
(snd-display ";poly/ 3: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector .5 1))))
- (if (not (and (vequal (car val) (float-vector -30.000 -4.000 2.000 0.000))
- (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -30.000 -4.000 2.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
(snd-display ";poly/ 4: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) (float-vector 3 7 2))))
- (if (not (and (vequal (car val) (float-vector -5.000 1.000 0.000 0.000))
- (vequal (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -5.000 1.000 0.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 0.000 0.000 0.000 0.000))))
(snd-display ";poly/ 5: ~A" val)))
(let ((val (poly/ (float-vector -15 -32 -3 2) 2.0)))
- (if (not (vequal (car val) (float-vector -7.500 -16.000 -1.500 1.000)))
+ (if (not (mus-arrays-equal? (car val) (float-vector -7.500 -16.000 -1.500 1.000)))
(snd-display ";poly/ 6: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 0.0 0.0 1.0) (float-vector 1.0 0.0 1.0))))
- (if (not (and (vequal (car val) (float-vector -1.0 0.0 1.0 0.0 0.0))
- (vequal (cadr val) (make-float-vector 5))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -1.0 0.0 1.0 0.0 0.0))
+ (mus-arrays-equal? (cadr val) (make-float-vector 5))))
(snd-display ";poly/ 7: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0) (float-vector 1.0 0.0 0.0 0.0 1.0))))
- (if (not (and (vequal (car val) (float-vector -1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0))
- (vequal (cadr val) (make-float-vector 9))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0))
+ (mus-arrays-equal? (cadr val) (make-float-vector 9))))
(snd-display ";poly/ 8: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 1.0) (float-vector -1.0 0.0 1.0))))
- (if (not (and (vequal (car val) (float-vector 1.0 0.0 0.0))
- (vequal (cadr val) (make-float-vector 3))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector 1.0 0.0 0.0))
+ (mus-arrays-equal? (cadr val) (make-float-vector 3))))
(snd-display ";poly/ 9: ~A" val)))
(let ((val (poly/ (float-vector -1.0 0.0 1.0) (float-vector 2.0 1.0))))
- (if (not (and (vequal (car val) (float-vector -2.000 1.000 0.000))
- (vequal (cadr val) (float-vector 3.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector -2.000 1.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 3.000 0.000 0.000))))
(snd-display ";poly/ 10: ~A" val)))
(let ((val (poly/ (float-vector 2 1) (float-vector -1.0 0.0 1.0))))
- (if (not (and (vequal (car val) (float-vector 0.0))
- (vequal (cadr val) (float-vector -1.000 0.000 1.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector 0.0))
+ (mus-arrays-equal? (cadr val) (float-vector -1.000 0.000 1.000))))
(snd-display ";poly/ 11: ~A" val)))
(let ((val (poly/ (float-vector 1 2 3 0 1) (float-vector 0 0 0 1))))
- (if (not (and (vequal (car val) (float-vector 0.000 1.000 0.000 0.000 0.000))
- (vequal (cadr val) (float-vector 1.000 2.000 3.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? (car val) (float-vector 0.000 1.000 0.000 0.000 0.000))
+ (mus-arrays-equal? (cadr val) (float-vector 1.000 2.000 3.000 0.000 0.000))))
(snd-display ";poly/ 12: ~A" val)))
(let ((ind (open-sound "1a.snd")))
@@ -12178,36 +12044,36 @@ EDITS: 2
(let ((vals (car (poly/ v1 v2)))
(res (make-float-vector 100)))
(set! (res 0) 1.0)
- (if (not (vequal vals res))
+ (if (not (mus-arrays-equal? vals res))
(snd-display ";poly1 1a: ~A" vals))))
(close-sound ind))
(let ((val (poly-derivative (float-vector 0.5 1.0 2.0 4.0))))
- (if (not (vequal val (float-vector 1.000 4.000 12.000))) (snd-display ";poly-derivative: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 4.000 12.000))) (snd-display ";poly-derivative: ~A" val)))
(let ((val (poly-reduce (float-vector 1 2 3))))
- (if (not (vequal val (float-vector 1.000 2.000 3.000))) (snd-display ";poly-reduce 1: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 2.000 3.000))) (snd-display ";poly-reduce 1: ~A" val)))
(let ((val (poly-reduce (float-vector 1 2 3 0 0 0))))
- (if (not (vequal val (float-vector 1.000 2.000 3.000))) (snd-display ";poly-reduce 2: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 2.000 3.000))) (snd-display ";poly-reduce 2: ~A" val)))
(let ((val (poly-reduce (float-vector 0 0 0 0 1 0))))
- (if (not (vequal val (float-vector 0.000 0.000 0.000 0.000 1.000))) (snd-display ";poly-reduce 3: ~A" val)))
+ (if (not (mus-arrays-equal? val (float-vector 0.000 0.000 0.000 0.000 1.000))) (snd-display ";poly-reduce 3: ~A" val)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 2 1) (float-vector -3 1))) (float-vector 2 1))))
- (if (not (vequal vals (float-vector 2.000 1.000))) (snd-display ";poly-gcd 1: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector 2.000 1.000))) (snd-display ";poly-gcd 1: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 2 1) (float-vector -3 1))) (float-vector 3 1))))
- (if (not (vequal vals (float-vector 0.000))) (snd-display ";poly-gcd 2: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000))) (snd-display ";poly-gcd 2: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 2 1) (float-vector -3 1))) (float-vector -3 1))))
- (if (not (vequal vals (float-vector -3.000 1.000))) (snd-display ";poly-gcd 2: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector -3.000 1.000))) (snd-display ";poly-gcd 2: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 8 1) (poly* (float-vector 2 1) (float-vector -3 1)))) (float-vector -3 1))))
- (if (not (vequal vals (float-vector -3.000 1.000))) (snd-display ";poly-gcd 3: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector -3.000 1.000))) (snd-display ";poly-gcd 3: ~A" vals)))
(let ((vals (poly-gcd (poly-reduce (poly* (float-vector 8 1) (poly* (float-vector 2 1) (float-vector -3 1)))) (poly-reduce (poly* (float-vector 8 1) (float-vector -3 1))))))
- (if (not (vequal vals (float-vector -24.000 5.000 1.000))) (snd-display ";poly-gcd 4: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector -24.000 5.000 1.000))) (snd-display ";poly-gcd 4: ~A" vals)))
(let ((vals (poly-gcd (float-vector -1 0 1) (float-vector 2 -2 -1 1))))
- (if (not (vequal vals (float-vector 0.000))) (snd-display ";poly-gcd 5: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000))) (snd-display ";poly-gcd 5: ~A" vals)))
(let ((vals (poly-gcd (float-vector 2 -2 -1 1) (float-vector -1 0 1))))
- (if (not (vequal vals (float-vector 1.000 -1.000))) (snd-display ";poly-gcd 6: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector 1.000 -1.000))) (snd-display ";poly-gcd 6: ~A" vals)))
(let ((vals (poly-gcd (float-vector 2 -2 -1 1) (float-vector -2.5 1))))
- (if (not (vequal vals (float-vector 0.000))) (snd-display ";poly-gcd 7: ~A" vals)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000))) (snd-display ";poly-gcd 7: ~A" vals)))
(poly-roots-tests)
@@ -12307,9 +12173,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v0 i) (delay gen i)))
- (let ((gen2 (make-delay 3)))
- (let ((k 0)) (fill-float-vector v1 (let ((val (if (delay? gen2) (delay gen2 k) -1.0))) (set! k (+ k 1)) val))))
- (if (not (vequal v1 v0)) (snd-display ";map delay: ~A ~A" v0 v1))
+ (let ((gen2 (make-delay 3))
+ (k 0))
+ (fill-float-vector v1 (let ((val (if (delay? gen2) (delay gen2 k) -1.0)))
+ (set! k (+ k 1))
+ val)))
+ (if (not (mus-arrays-equal? v1 v0)) (snd-display ";map delay: ~A ~A" v0 v1))
(if (not (delay? gen)) (snd-display ";~A not delay?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";delay length: ~D?" (mus-length gen)))
(if (or (fneq (v0 1) 0.0) (fneq (v0 4) 1.0) (fneq (v0 8) 5.0))
@@ -12369,16 +12238,13 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 5))
(set! (v0 i) (delay del 0.0 0.4)))
- (if (not (vequal v0 (float-vector 0.600 0.400 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.600 0.400 0.000 0.000 0.000)))
(snd-display ";zdelay: ~A" v0)))
(delay del 1.0)
(delay del 0.0 0.4)
(if (not (string=? (mus-describe del) "delay line[5,8, linear]: [0 0 1 0 0]"))
(snd-display ";describe zdelay: ~A" (mus-describe del))))
- (let ((tag (catch #t (lambda ()
- (let ((gen (make-oscil)))
- (tap gen)))
- (lambda args (car args)))))
+ (let ((tag (catch #t (lambda () (tap (make-oscil))) (lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg))
(snd-display ";tap of oscil: ~A" tag)))
@@ -12389,7 +12255,7 @@ EDITS: 2
(fill-float-vector v (let ((res (delay dly (+ inval (* (one-zero flt (tap dly)) .6)))))
(set! inval 0.0)
res))
- (if (not (vequal v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 0.300 0.240 0.0 0.090 0.144 0.058 0.027 0.065 0.052 0.022 0.026 0.031 0.019 0.013)))
+ (if (not (mus-arrays-equal? v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 0.300 0.240 0.0 0.090 0.144 0.058 0.027 0.065 0.052 0.022 0.026 0.031 0.019 0.013)))
(snd-display ";tap with low pass: ~A" v)))
(let ((dly (make-delay 3))
@@ -12398,7 +12264,7 @@ EDITS: 2
(fill-float-vector v (let ((res (delay dly (+ inval (tap dly)))))
(set! inval 0.0)
res))
- (if (not (vequal v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0)))
+ (if (not (mus-arrays-equal? v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0 0.0 1.0 0.0)))
(snd-display ";simple tap: ~A" v)))
(let ((dly (make-delay 6))
@@ -12409,7 +12275,7 @@ EDITS: 2
(set! inval 0.0)
res))
(set! *print-length* (max 20 *print-length*))
- (if (not (vequal v (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0)))
+ (if (not (mus-arrays-equal? v (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0)))
(snd-display ";tap back 2: ~A" v)))
(let ((dly (make-delay 3))
@@ -12421,7 +12287,7 @@ EDITS: 2
(set! (v i) (let ((res (delay dly (+ inval (* (one-zero flt (tap dly)) .6)))))
(set! inval 0.0)
res)))
- (if (not (vequal v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 0.300 0.240 0.0 0.090 0.144 0.058 0.027 0.065 0.052 0.022 0.026 0.031 0.019 0.013)))
+ (if (not (mus-arrays-equal? v (float-vector 0.0 0.0 0.0 1.0 0.0 0.0 0.300 0.240 0.0 0.090 0.144 0.058 0.027 0.065 0.052 0.022 0.026 0.031 0.019 0.013)))
(snd-display ";tap with low pass: ~A" v)))
(let ((dly (make-delay 3 :initial-element 32.0)))
@@ -12436,8 +12302,7 @@ EDITS: 2
(if (not (eq? tag 'out-of-range)) (snd-display ";len to 100 -> ~A" tag)))
(let ((tag (catch #t (lambda () (set! ((mus-data dly) 100) .1)) (lambda args (car args)))))
(if (not (eq? tag 'out-of-range)) (snd-display ";data 100 to .1 -> ~A" tag)))
- (let ((data (make-float-vector 32 1.0)))
- (set! (mus-data dly) data))
+ (set! (mus-data dly) (make-float-vector 32 1.0))
(if (not (float-vector? (mus-data dly))) (snd-display ";set delay data not float-vector?"))
(if (fneq ((mus-data dly) 1) 1.0) (snd-display ";set delay [1] 1: ~A" ((mus-data dly) 1)))
(if (not (= (length (mus-data dly)) 32)) (snd-display ";set delay data len(32): ~A" (length (mus-data dly))))
@@ -12486,21 +12351,21 @@ EDITS: 2
(set! (v6 i) (tap d6 j))
(set! (v7 i) (tap d7 j)))
(set! *print-length* (max 20 *print-length*))
- (if (not (or (vequal v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))
- (vequal v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
+ (if (not (or (mus-arrays-equal? v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))
+ (mus-arrays-equal? v1 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
(snd-display ";delay interp none (1): ~A" v1))
- (if (not (vequal v2 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.200 0.400 0.600 0.800 1.0 0.800 0.600 0.400 0.200 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? v2 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.200 0.400 0.600 0.800 1.0 0.800 0.600 0.400 0.200 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";delay interp linear (2): ~A" v2))
- (if (not (vequal v3 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.600 0.160 0.168 -0.168 0.334 0.199 0.520 0.696 -0.696 0.557 -0.334 0.134 -0.027)))
+ (if (not (mus-arrays-equal? v3 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.600 0.160 0.168 -0.168 0.334 0.199 0.520 0.696 -0.696 0.557 -0.334 0.134 -0.027)))
(snd-display ";delay interp all-pass (3): ~A" v3))
- (if (not (or (vequal v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))
- (vequal v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
+ (if (not (or (mus-arrays-equal? v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))
+ (mus-arrays-equal? v4 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 0.0))))
(snd-display ";delay interp none (4): ~A" v4))
- (if (not (vequal v5 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.120 0.280 0.480 0.720 1.000 0.960 0.840 0.640 0.360 0.000 -0.080 -0.120 -0.120 -0.080)))
+ (if (not (mus-arrays-equal? v5 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.120 0.280 0.480 0.720 1.000 0.960 0.840 0.640 0.360 0.000 -0.080 -0.120 -0.120 -0.080)))
(snd-display ";delay interp lagrange (5): ~A" v5))
- (if (not (vequal v6 (float-vector 0.0 -0.016 -0.048 -0.072 -0.064 0.0 0.168 0.424 0.696 0.912 1.0 0.912 0.696 0.424 0.168 0.0 -0.064 -0.072 -0.048 -0.016)))
+ (if (not (mus-arrays-equal? v6 (float-vector 0.0 -0.016 -0.048 -0.072 -0.064 0.0 0.168 0.424 0.696 0.912 1.0 0.912 0.696 0.424 0.168 0.0 -0.064 -0.072 -0.048 -0.016)))
(snd-display ";delay interp hermite (6): ~A" v6))
- (if (not (vequal v7 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.200 0.400 0.600 0.800 1.0 0.800 0.600 0.400 0.200 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? v7 (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.200 0.400 0.600 0.800 1.0 0.800 0.600 0.400 0.200 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";delay interp linear (7): ~A" v7)))
(let ((dly1 (make-delay :size 2 :max-size 3))
@@ -12510,7 +12375,7 @@ EDITS: 2
((= i 5))
(set! (data i) (delay dly1 impulse 0.4)) ; longer line
(set! impulse 0.0))
- (if (not (vequal data (float-vector 0.0 0.0 0.6 0.4 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.0 0.6 0.4 0.0)))
(snd-display ";delay size 2, max 3, off 0.4: ~A" data))
(set! dly1 (make-delay :size 2 :max-size 3))
@@ -12519,7 +12384,7 @@ EDITS: 2
((= i 5))
(set! (data i) (delay dly1 impulse -0.4)) ; shorter line
(set! impulse 0.0))
- (if (not (vequal data (float-vector 0.0 0.4 0.6 0.0 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.4 0.6 0.0 0.0)))
(snd-display ";delay size 2, max 3, off -0.4: ~A" data))
(set! dly1 (make-delay :size 1 :max-size 2))
@@ -12528,7 +12393,7 @@ EDITS: 2
((= i 5))
(set! (data i) (delay dly1 impulse 0.4))
(set! impulse 0.0))
- (if (not (vequal data (float-vector 0.0 0.6 0.4 0.0 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.6 0.4 0.0 0.0)))
(snd-display ";delay size 1, max 2, off 0.4: ~A" data))
(set! dly1 (make-delay :size 0 :max-size 1))
@@ -12537,7 +12402,7 @@ EDITS: 2
((= i 5))
(set! (data i) (delay dly1 impulse 0.4))
(set! impulse 0.0))
- (if (not (vequal data (float-vector 0.6 0.4 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.6 0.4 0.0 0.0 0.0)))
(snd-display ";delay size 0, max 1, off 0.4: ~A" data))
(set! dly1 (make-delay :size 0 :max-size 1))
@@ -12550,7 +12415,7 @@ EDITS: 2
((= i 5))
(set! (data i) (delay dly1 impulse -0.4)) ; shorter than 0? should this be an error?
(set! impulse 0.0))
- (if (not (vequal data (float-vector 1.4 -0.4 0.0 0.0 0.0))) ; hmmm -- they're asking for undefined values here
+ (if (not (mus-arrays-equal? data (float-vector 1.4 -0.4 0.0 0.0 0.0))) ; hmmm -- they're asking for undefined values here
(snd-display ";delay size 0, max 1, off -0.4: ~A" data))
(set! dly1 (make-delay 0))
@@ -12559,7 +12424,7 @@ EDITS: 2
((= i 5))
(set! (data i) (delay dly1 impulse))
(set! impulse 0.0))
- (if (not (vequal data (float-vector 1 0 0 0 0)))
+ (if (not (mus-arrays-equal? data (float-vector 1 0 0 0 0)))
(snd-display ";delay size 0: ~A" data))
(let ((x (delay dly1 0.5)))
(if (fneq x 0.5)
@@ -12571,26 +12436,26 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (delay gen 0.5 i)))
- (if (not (vequal v (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";delay 0 -> 100: ~A" v))
(do ((i 9 (- i 1)))
((< i 0))
(set! (v i) (delay gen 0.5 i)))
- (if (not (vequal v (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500 0.500)))
(snd-display ";delay 100 -> 0: ~A" v))
(mus-reset gen)
- (if (not (vequal (mus-data gen) (make-float-vector 100 0.0)))
+ (if (not (mus-arrays-equal? (mus-data gen) (make-float-vector 100)))
(snd-display ";after reset mus-data delay peak: ~A" (float-vector-peak (mus-data gen))))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (delay gen (if (odd? i) 1.0 0.0) (* i .1))))
- (if (not (vequal v (float-vector 0.000 0.900 0.000 0.700 0.000 0.500 0.000 0.300 0.000 0.100)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.900 0.000 0.700 0.000 0.500 0.000 0.300 0.000 0.100)))
(snd-display ";delay 0 -> 100 .1: ~A (~A)" v gen))
(mus-reset gen)
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (delay gen (if (odd? i) 1.0 0.0) (+ 1.0 (* i .1)))))
- (if (not (vequal v (float-vector 0.000 0.000 0.800 0.300 0.600 0.500 0.400 0.700 0.200 0.900)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.800 0.300 0.600 0.500 0.400 0.700 0.200 0.900)))
(snd-display ";delay 0 -> 100 1.1: ~A" v)))
@@ -12605,7 +12470,7 @@ EDITS: 2
(let ((gen1 (make-all-pass .4 .6 3))
(v1 (make-float-vector 10)))
(fill-float-vector v1 (if (all-pass? gen1) (all-pass gen1 1.0) -1.0))
- (if (not (vequal v1 v0)) (snd-display ";map all-pass: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v1 v0)) (snd-display ";map all-pass: ~A ~A" v0 v1)))
(if (not (all-pass? gen)) (snd-display ";~A not all-pass?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";all-pass length: ~D?" (mus-length gen)))
(if (not (= (mus-order gen) 3)) (snd-display ";all-pass order: ~D?" (mus-order gen)))
@@ -12645,7 +12510,7 @@ EDITS: 2
(let ((gen1 (make-moving-average 4))
(v1 (make-float-vector 10)))
(fill-float-vector v1 (if (moving-average? gen1) (moving-average gen1 1.0) -1.0))
- (if (not (vequal v1 v0)) (snd-display ";map average: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v1 v0)) (snd-display ";map average: ~A ~A" v0 v1)))
(if (not (moving-average? gen)) (snd-display ";~A not average?" gen))
(if (not (= (mus-length gen) 4)) (snd-display ";average length: ~D?" (mus-length gen)))
(if (not (= (mus-order gen) 4)) (snd-display ";average order: ~D?" (mus-order gen)))
@@ -12668,13 +12533,11 @@ EDITS: 2
(set! val (moving-average gen 0.0))
(if (fneq val 0.0625) (snd-display ";average 8: ~A" val))
(set! val (moving-average gen 0.0))
- (if (fneq val 0.0) (snd-display ";average 9: ~A" val))
- )
- (let* ((gen (make-moving-average 10 :initial-element .5))
- (val (moving-average gen 0.5)))
+ (if (fneq val 0.0) (snd-display ";average 9: ~A" val)))
+
+ (let ((val (moving-average (make-moving-average 10 :initial-element .5) 0.5)))
(if (fneq val 0.5) (snd-display ";average initial-element: ~A" val)))
- (let* ((gen (make-moving-average 3 :initial-contents '(1.0 1.0 1.0)))
- (val (moving-average gen 1.0)))
+ (let ((val (moving-average (make-moving-average 3 :initial-contents '(1.0 1.0 1.0)) 1.0)))
(if (fneq val 1.0) (snd-display ";average initial-contents: ~A" val)))
(test-gen-equal (let ((d1 (make-moving-average 3 :initial-contents '(0.7 0.5 3)))) (moving-average d1 1.0) d1)
@@ -12707,7 +12570,7 @@ EDITS: 2
(set! (v0 i) (moving-max gen 1.0)))
(let ((gen1 (make-moving-max 4)))
(fill-float-vector v1 (if (moving-max? gen1) (moving-max gen1 1.0) -1.0)))
- (if (not (vequal v1 v0)) (snd-display ";map max: ~A ~A" v0 v1))
+ (if (not (mus-arrays-equal? v1 v0)) (snd-display ";map max: ~A ~A" v0 v1))
(if (not (moving-max? gen)) (snd-display ";~A not max?" gen))
(if (not (= (mus-length gen) 4)) (snd-display ";max length: ~D?" (mus-length gen)))
(if (not (= (mus-order gen) 4)) (snd-display ";max order: ~D?" (mus-order gen)))
@@ -12730,13 +12593,11 @@ EDITS: 2
(set! val (moving-max gen 0.0))
(if (fneq val 1.5) (snd-display ";max 8: ~A" val))
(set! val (moving-max gen 0.0))
- (if (fneq val 0.0) (snd-display ";max 9: ~A" val))
- )
- (let* ((gen (make-moving-max 10 :initial-element .5))
- (val (moving-max gen 0.5)))
+ (if (fneq val 0.0) (snd-display ";max 9: ~A" val)))
+
+ (let ((val (moving-max (make-moving-max 10 :initial-element .5) 0.5)))
(if (fneq val 0.5) (snd-display ";max initial-element: ~A" val)))
- (let* ((gen (make-moving-max 3 :initial-contents '(1.0 1.0 1.0)))
- (val (moving-max gen 1.0)))
+ (let ((val (moving-max (make-moving-max 3 :initial-contents '(1.0 1.0 1.0)) 1.0)))
(if (fneq val 1.0) (snd-display ";max initial-contents: ~A" val)))
(test-gen-equal (let ((d1 (make-moving-max 3 :initial-contents '(0.7 0.5 3)))) (moving-max d1 1.0) d1)
@@ -12769,7 +12630,7 @@ EDITS: 2
(set! (v0 i) (moving-norm gen 1.0)))
(let ((gen1 (make-moving-norm 4)))
(fill-float-vector v1 (if (moving-norm? gen1) (moving-norm gen1 1.0) -1.0)))
- (if (not (vequal v1 v0)) (snd-display ";map norm: ~A ~A" v0 v1))
+ (if (not (mus-arrays-equal? v1 v0)) (snd-display ";map norm: ~A ~A" v0 v1))
(if (not (moving-norm? gen)) (snd-display ";~A not norm?" gen))
(if (not (= (mus-length gen) 4)) (snd-display ";norm length: ~D?" (mus-length gen)))
(if (not (= (mus-order gen) 4)) (snd-display ";norm order: ~D?" (mus-order gen))))
@@ -12790,13 +12651,11 @@ EDITS: 2
(set! val (moving-norm gen 0.0))
(if (fneq val 0.7866) (snd-display ";norm 8: ~A" val))
(set! val (moving-norm gen 0.0))
- (if (fneq val 0.8841) (snd-display ";norm 9: ~A" val))
- )
- (let* ((gen (make-moving-norm 10 :initial-element .5))
- (val (moving-norm gen 0.5)))
+ (if (fneq val 0.8841) (snd-display ";norm 9: ~A" val)))
+
+ (let ((val (moving-norm (make-moving-norm 10 :initial-element .5) 0.5)))
(if (fneq val 1.0476) (snd-display ";norm initial-element: ~A" val)))
- (let* ((gen (make-moving-norm 3 :initial-contents '(1.0 1.0 1.0)))
- (val (moving-norm gen 1.0)))
+ (let ((val (moving-norm (make-moving-norm 3 :initial-contents '(1.0 1.0 1.0)) 1.0)))
(if (fneq val 1.0) (snd-display ";norm initial-contents: ~A" val)))
(test-gen-equal (let ((d1 (make-moving-norm 3))) (moving-norm d1 1.0) d1)
@@ -12824,7 +12683,7 @@ EDITS: 2
(set! (v0 i) (comb gen 1.0)))
(let ((gen1 (make-comb .4 3)))
(fill-float-vector v1 (if (comb? gen1) (comb gen1 1.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map comb: ~A ~A" v0 v1))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map comb: ~A ~A" v0 v1))
(if (not (comb? gen)) (snd-display ";~A not comb?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";comb length: ~D?" (mus-length gen)))
(if (not (= (mus-order gen) 3)) (snd-display ";comb order: ~D?" (mus-order gen)))
@@ -12852,7 +12711,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 5))
(set! (v0 i) (comb del 0.0 0.4)))
- (if (not (vequal v0 (float-vector 0.600 0.400 0.000 0.000 0.000))) ; this is assuming interpolation in the delay...
+ (if (not (mus-arrays-equal? v0 (float-vector 0.600 0.400 0.000 0.000 0.000))) ; this is assuming interpolation in the delay...
(snd-display ";zcomb: ~A" v0)))
(comb del 1.0)
(comb del 0.0 0.4)
@@ -12873,7 +12732,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (filtered-comb gen val))
(set! val 0.0)))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.120 0.280 0.000 0.000 0.000 0.014 0.067 0.078 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.120 0.280 0.000 0.000 0.000 0.014 0.067 0.078 0.000 0.000)))
(snd-display ";filtered-comb: ~A" v0)))
(if (not (filtered-comb? gen)) (snd-display ";~A not filtered-comb?" gen))
(if (not (= (mus-length gen) 5)) (snd-display ";filtered-comb length: ~D?" (mus-length gen)))
@@ -12890,7 +12749,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (filtered-comb gen val))
(set! val 0.0)))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.450 0.450 0.000 0.000 0.000 0.202 0.405 0.202 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.450 0.450 0.000 0.000 0.000 0.202 0.405 0.202 0.000 0.000)))
(snd-display ";filtered-comb .5 .5: ~A" v0)))
(let ((gen (make-filtered-comb .9 5 :filter (make-fir-filter 5 (float-vector .1 .2 .3 .2 .1))))
@@ -12903,7 +12762,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (filtered-comb gen val))
(set! val 0.0)))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.090 0.180 0.270 0.180 0.090 0.008 0.032 0.081 0.130 0.154)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.090 0.180 0.270 0.180 0.090 0.008 0.032 0.081 0.130 0.154)))
(snd-display ";filtered-comb fir: ~A" v0)))
(test-gen-equal (let ((d1 (make-filtered-comb 0.7 3 :filter (make-one-pole .3 .7)))) (filtered-comb d1 1.0) d1)
@@ -12926,7 +12785,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 5))
(set! (v0 i) (filtered-comb del 0.0 0.4)))
- (if (not (vequal v0 (float-vector 0.600 0.400 0.000 0.000 0.000))) ; this is assuming interpolation in the delay...
+ (if (not (mus-arrays-equal? v0 (float-vector 0.600 0.400 0.000 0.000 0.000))) ; this is assuming interpolation in the delay...
(snd-display ";zfiltered-comb: ~A" v0)))
(filtered-comb del 1.0)
(filtered-comb del 0.0 0.4)
@@ -12949,7 +12808,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-notch .4 3)))
(fill-float-vector v1 (if (notch? gen1) (notch gen1 1.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map notch: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map notch: ~A ~A" v0 v1)))
(if (not (notch? gen)) (snd-display ";~A not notch?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";notch length: ~D?" (mus-length gen)))
(if (not (= (mus-order gen) 3)) (snd-display ";notch order: ~D?" (mus-order gen)))
@@ -12982,7 +12841,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (comb gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
(snd-display ";comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5))
@@ -12992,7 +12851,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
(snd-display ";all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5))
@@ -13002,7 +12861,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (notch gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5))
@@ -13012,7 +12871,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";all-pass (5 .5 0): ~A" v0)))
;; make sure zall-pass is the same as zcomb/znotch given the appropriate feedback/forward and "pm" settings
@@ -13024,7 +12883,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (comb gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
(snd-display ";1comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
@@ -13034,7 +12893,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.500)))
(snd-display ";1all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
@@ -13044,7 +12903,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (notch gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";1notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
@@ -13054,7 +12913,7 @@ EDITS: 2
((= i 11))
(set! (v0 i) (all-pass gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";1all-pass (5 .5 0): ~A" v0)))
;; now actually use the size difference
@@ -13067,7 +12926,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (comb gen in1 phase))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.160 0.360 0.200 0.040 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.160 0.360 0.200 0.040 0.000 0.000 0.000)))
(snd-display ";2comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
@@ -13078,7 +12937,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.160 0.360 0.200 0.040 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.160 0.360 0.200 0.040 0.000 0.000 0.000)))
(snd-display ";2all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
@@ -13089,7 +12948,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";2notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
@@ -13100,7 +12959,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";2all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-comb 0.5 5 :max-size 20))
@@ -13111,7 +12970,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.160 0.160 0.000 0.080 0.064 0.016 0.035 0.013 0.018 0.007 0.007 0.003 0.002)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.160 0.160 0.000 0.080 0.064 0.016 0.035 0.013 0.018 0.007 0.007 0.003 0.002)))
(snd-display ";3comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
@@ -13122,7 +12981,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.160 0.160 0.000 0.080 0.064 0.016 0.035 0.013 0.018 0.007 0.007 0.003 0.002)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.160 0.160 0.000 0.080 0.064 0.016 0.035 0.013 0.018 0.007 0.007 0.003 0.002)))
(snd-display ";3all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
@@ -13133,7 +12992,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";3notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
@@ -13144,7 +13003,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.800 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";3all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-comb 0.5 5 :max-size 20))
@@ -13155,7 +13014,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.428 0.079 0.004 0.000 0.000 0.182 0.067 0.008 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.428 0.079 0.004 0.000 0.000 0.182 0.067 0.008 0.000 0.000)))
(snd-display ";4comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 20))
@@ -13166,7 +13025,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.428 0.079 0.004 0.000 0.000 0.182 0.067 0.008 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.428 0.079 0.004 0.000 0.000 0.182 0.067 0.008 0.000 0.000)))
(snd-display ";4all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 20))
@@ -13177,7 +13036,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";4notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 20))
@@ -13188,7 +13047,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";4all-pass (5 .5 0): ~A" v0)))
;; now run off either end of the delay line "by accident"
@@ -13201,7 +13060,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.250 0.125 0.094 0.062 0.055 0.047 0.039 0.031 0.029)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.250 0.125 0.094 0.062 0.055 0.047 0.039 0.031 0.029)))
(snd-display ";5comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 10))
@@ -13212,7 +13071,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.250 0.125 0.094 0.062 0.055 0.047 0.039 0.031 0.029)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.250 0.125 0.094 0.062 0.055 0.047 0.039 0.031 0.029)))
(snd-display ";5all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 10))
@@ -13223,7 +13082,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";5notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 10))
@@ -13234,7 +13093,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.500 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";5all-pass (5 .5 0): ~A" v0)))
@@ -13246,7 +13105,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.500 0.000 0.125 0.000 0.031 0.016 0.004 1.000 0.000 0.250 0.031 0.000 0.012 0.002 0.250 0.125 0.008)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.500 0.000 0.125 0.000 0.031 0.016 0.004 1.000 0.000 0.250 0.031 0.000 0.012 0.002 0.250 0.125 0.008)))
(snd-display ";6comb (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.5 0.0 5 :max-size 10))
@@ -13257,7 +13116,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.500 0.000 0.125 0.000 0.031 0.016 0.004 1.000 0.000 0.250 0.031 0.000 0.012 0.002 0.250 0.125 0.008)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.500 0.000 0.125 0.000 0.031 0.016 0.004 1.000 0.000 0.250 0.031 0.000 0.012 0.002 0.250 0.125 0.008)))
(snd-display ";6all-pass (5 0 .5): ~A" v0)))
(let ((gen (make-notch 0.5 5 :max-size 10))
@@ -13268,7 +13127,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (notch gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";6notch (5 .5): ~A" v0)))
(let ((gen (make-all-pass 0.0 0.5 5 :max-size 10))
@@ -13279,7 +13138,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (all-pass gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.500 0.000 0.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.500 0.000 0.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";6all-pass (5 .5 0): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .5 .5)))
@@ -13289,7 +13148,7 @@ EDITS: 2
((= i 21))
(set! (v0 i) (filtered-comb gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.250 0.250
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.250 0.250
0.000 0.000 0.000 0.062 0.125 0.062 0.000 0.000 0.016)))
(snd-display ";filtered-comb (5 .5): ~A" v0)))
@@ -13300,30 +13159,18 @@ EDITS: 2
((= i 21))
(set! (v0 i) (filtered-comb gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
0.000 0.000 0.000 0.016 0.094 0.141 0.000 0.000 0.002)))
(snd-display ";1filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .25 .75)))
(v0 (make-float-vector 21))
(in1 1.0))
- (define mus-filtered-comb filtered-comb)
- (do ((i 0 (+ i 1)))
- ((= i 21))
- (set! (v0 i) (mus-filtered-comb gen in1))
- (set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
- 0.000 0.000 0.000 0.016 0.094 0.141 0.000 0.000 0.002)))
- (snd-display ";1mus-filtered-comb (5 .5): ~A" v0)))
-
- (let ((gen (make-filtered-comb 0.5 5 :filter (make-one-zero .25 .75)))
- (v0 (make-float-vector 21))
- (in1 1.0))
(do ((i 0 (+ i 1)))
((= i 21))
(set! (v0 i) (filtered-comb gen in1))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.125 0.375
0.000 0.000 0.000 0.016 0.094 0.141 0.000 0.000 0.002)))
(snd-display ";1run-filtered-comb (5 .5): ~A" v0)))
@@ -13335,7 +13182,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (filtered-comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.080 0.220 0.300 0.140 0.040 0.000 0.000)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.800 0.400 0.000 0.000 0.000 0.000 0.000 0.080 0.220 0.300 0.140 0.040 0.000 0.000)))
(snd-display ";2filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :max-size 20 :filter (make-one-zero .5 .5)))
@@ -13346,7 +13193,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (filtered-comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.080 0.200 0.040 0.020 0.068 0.042 0.019 0.026 0.015 0.011 0.009 0.006 0.004)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.800 0.000 0.000 0.080 0.200 0.040 0.020 0.068 0.042 0.019 0.026 0.015 0.011 0.009 0.006 0.004)))
(snd-display ";3filtered-comb (5 .5): ~A" v0)))
(let ((gen (make-filtered-comb 0.5 5 :max-size 20 :filter (make-one-zero .5 .5)))
@@ -13357,7 +13204,7 @@ EDITS: 2
((= i 20))
(set! (v0 i) (filtered-comb gen in1 angle))
(set! in1 0.0))
- (if (not (vequal v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.214 0.251 0.043 0.002 0.000 0.045 0.106 0.081 0.023 0.003)))
+ (if (not (mus-arrays-equal? v0 (float-vector 0.000 0.000 0.000 0.000 0.000 0.950 0.060 0.000 0.000 0.000 0.214 0.251 0.043 0.002 0.000 0.045 0.106 0.081 0.023 0.003)))
(snd-display ";4filtered-comb (5 .5): ~A" v0)))
@@ -13372,7 +13219,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-one-pole .4 .7)))
(fill-float-vector v1 (if (one-pole? gen) (one-pole gen1 1.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map one-pole: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map one-pole: ~A ~A" v0 v1)))
(if (not (one-pole? gen)) (snd-display ";~A not one-pole?" gen))
(if (not (= (mus-order gen) 1)) (snd-display ";one-pole order: ~D?" (mus-order gen)))
(if (fneq (mus-xcoeff gen 0) .4) (snd-display ";one-pole a0: ~F?" (mus-xcoeff gen 0)))
@@ -13398,7 +13245,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-one-zero .4 .7)))
(fill-float-vector v1 (if (one-zero? gen) (one-zero gen1 1.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map one-zero: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map one-zero: ~A ~A" v0 v1)))
(if (not (one-zero? gen)) (snd-display ";~A not one-zero?" gen))
(if (not (= (mus-order gen) 1)) (snd-display ";one-zero order: ~D?" (mus-order gen)))
(if (fneq (mus-xcoeff gen 0) .4) (snd-display ";one-zero a0: ~F?" (mus-xcoeff gen 0)))
@@ -13419,7 +13266,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-two-zero .4 .7 .3)))
(fill-float-vector v1 (if (two-zero? gen1) (two-zero gen1 1.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map two-zero: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map two-zero: ~A ~A" v0 v1)))
(if (not (two-zero? gen)) (snd-display ";~A not two-zero?" gen))
(if (not (= (mus-order gen) 2)) (snd-display ";two-zero order: ~D?" (mus-order gen)))
(if (fneq (mus-xcoeff gen 0) .4) (snd-display ";two-zero a0: ~F?" (mus-xcoeff gen 0)))
@@ -13443,13 +13290,13 @@ EDITS: 2
(fneq (mus-xcoeff gen 2) (mus-xcoeff g3 2)))
(snd-display ";two-zero setters: ~A ~A" gen g3))))
- (let ((gen (make-two-zero .4 .7 .3)))
- (let ((val (gen 1.0)))
- (if (fneq val .4) (snd-display ";2zero->0.4: ~A" val))
- (set! val (gen 0.5))
- (if (fneq val .9) (snd-display ";2zero->0.9: ~A" val))
- (set! val (gen 1.0))
- (if (fneq val 1.05) (snd-display ";2zero->1.05: ~A" val))))
+ (let* ((gen (make-two-zero .4 .7 .3))
+ (val (gen 1.0)))
+ (if (fneq val .4) (snd-display ";2zero->0.4: ~A" val))
+ (set! val (gen 0.5))
+ (if (fneq val .9) (snd-display ";2zero->0.9: ~A" val))
+ (set! val (gen 1.0))
+ (if (fneq val 1.05) (snd-display ";2zero->1.05: ~A" val)))
(let ((gen (make-two-pole .4 .7 .3))
(v0 (make-float-vector 10)))
@@ -13462,7 +13309,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-two-pole .4 .7 .3)))
(fill-float-vector v1 (if (two-pole? gen1) (two-pole gen1 1.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map two-pole: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map two-pole: ~A ~A" v0 v1)))
(if (not (two-pole? gen)) (snd-display ";~A not two-pole?" gen))
(if (not (= (mus-order gen) 2)) (snd-display ";two-pole order: ~D?" (mus-order gen)))
(if (fneq (mus-xcoeff gen 0) .4) (snd-display ";two-pole a0: ~F?" (mus-xcoeff gen 0)))
@@ -13489,13 +13336,13 @@ EDITS: 2
(fneq (mus-ycoeff gen 2) (mus-ycoeff g3 2)))
(snd-display ";two-pole setters: ~A ~A" gen g3))))
- (let ((gen (make-two-pole .4 .7 .3)))
- (let ((val (gen 1.0)))
- (if (fneq val .4) (snd-display ";a0->out 2pole: ~A" val))
- (set! val (gen 0.5))
- (if (fneq val -.08) (snd-display ";a0->out 2pole (-0.08): ~A" val))
- (set! val (gen 1.0))
- (if (fneq val 0.336) (snd-display ";a0->out 2pole (0.336): ~A" val))))
+ (let* ((gen (make-two-pole .4 .7 .3))
+ (val (gen 1.0)))
+ (if (fneq val .4) (snd-display ";a0->out 2pole: ~A" val))
+ (set! val (gen 0.5))
+ (if (fneq val -.08) (snd-display ";a0->out 2pole (-0.08): ~A" val))
+ (set! val (gen 1.0))
+ (if (fneq val 0.336) (snd-display ";a0->out 2pole (0.336): ~A" val)))
(let ((gen (make-oscil 440.0))
(v0 (make-float-vector 10))
@@ -13511,7 +13358,7 @@ EDITS: 2
(let ((v2 (make-float-vector 10)))
(let ((gen2 (make-oscil 440.0)))
(fill-float-vector v2 (if (oscil? gen2) (oscil gen2 0.0) -1.0)))
- (if (not (vequal v0 v2)) (snd-display ";map oscil: ~A ~A" v0 v2)))
+ (if (not (mus-arrays-equal? v0 v2)) (snd-display ";map oscil: ~A ~A" v0 v2)))
(if (not (oscil? gen)) (snd-display ";~A not oscil?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";oscil phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";oscil frequency: ~F?" (mus-frequency gen)))
@@ -13732,10 +13579,10 @@ EDITS: 2
(ho-1 o1 v1 1)
(do ((i 0 (+ i 1)))
((= i 10))
- (ho-1 o2 v2 i))
+ (set! (v2 i) (oscil o2)))
(do ((i 2 (+ i 1)))
((= i 10))
- (ho-1 o1 v1 i))
+ (set! (v1 i) (oscil o1)))
(if (not (equal? v1 v2))
(snd-display ";oscil-1 shadowing test2: ~A ~A" v1 v2))))
@@ -13809,7 +13656,7 @@ EDITS: 2
(let ((v1 (with-sound ((make-float-vector size) :srate 441000) (test-pm 0 size 20 1 1 1)))
(v2 (with-sound ((make-float-vector size) :srate 441000) (test-fm 0 size 20 1 1 1))))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";fm/pm peak diff (1 1): ~A" (float-vector-peak (float-vector-subtract! v1 v2)))))
(do ((i 0 (+ i 1)))
@@ -13818,7 +13665,7 @@ EDITS: 2
(index (random 2.0)))
(let ((v1 (with-sound ((make-float-vector size) :srate 441000) (test-pm 0 size 20 1 ratio index)))
(v2 (with-sound ((make-float-vector size) :srate 441000) (test-fm 0 size 20 1 ratio index))))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";fm/pm peak diff ~A ~A: ~A" ratio index (float-vector-peak (float-vector-subtract! v1 v2))))))))
(let ((gen (make-ncos 440.0 10))
@@ -13832,13 +13679,13 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-ncos 440.0 10)))
(fill-float-vector v1 (if (ncos? gen1) (ncos gen1 0.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map ncos: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map ncos: ~A ~A" v0 v1)))
(if (not (ncos? gen)) (snd-display ";~A not ncos?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";ncos phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";ncos frequency: ~F?" (mus-frequency gen)))
(if (fneq (mus-scaler gen) .1) (snd-display ";ncos scaler: ~F?" (mus-scaler gen)))
- (if (not (= (mus-length gen) 10)) (snd-display ";ncos n: ~D?" (mus-length gen)))
- (if (not (= (mus-length gen) 10)) (snd-display ";ncos length: ~D?" (mus-length gen)))
+ (unless (= (mus-length gen) 10)
+ (snd-display ";ncos n: ~D?" (mus-length gen)))
(if (or (fneq (v0 1) 0.722) (fneq (v0 8) -0.143)) (snd-display ";ncos output: ~A" v0))
(set! (mus-scaler gen) .5) (if (fneq (mus-scaler gen) 0.5) (snd-display ";ncos set-scaler: ~F?" (mus-scaler gen)))
(set! (mus-length gen) 5) (if (not (= (mus-length gen) 5)) (snd-display ";set ncos n: ~D?" (mus-length gen)))
@@ -13887,13 +13734,13 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-nsin 440.0 10)))
(fill-float-vector v1 (if (nsin? gen1) (nsin gen1 0.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map nsin: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map nsin: ~A ~A" v0 v1)))
(if (not (nsin? gen)) (snd-display ";~A not nsin?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";nsin phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";nsin frequency: ~F?" (mus-frequency gen)))
(if (fneq (mus-scaler gen) .1315) (snd-display ";nsin scaler: ~F?" (mus-scaler gen)))
- (if (not (= (mus-length gen) 10)) (snd-display ";nsin n: ~D?" (mus-length gen)))
- (if (not (= (mus-length gen) 10)) (snd-display ";nsin length: ~D?" (mus-length gen)))
+ (unless (= (mus-length gen) 10)
+ (snd-display ";nsin n: ~D?" (mus-length gen)))
(if (or (fneq (v0 1) 0.784) (fneq (v0 8) 0.181)) (snd-display ";nsin output: ~A" v0))
(set! (mus-scaler gen) .5) (if (fneq (mus-scaler gen) 0.5) (snd-display ";nsin set-scaler: ~F?" (mus-scaler gen)))
(set! (mus-length gen) 5) (if (not (= (mus-length gen) 5)) (snd-display ";set nsin n: ~D?" (mus-length gen)))
@@ -13927,7 +13774,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-nrxysin 440.0)))
(fill-float-vector v1 (if (nrxysin? gen1) (nrxysin gen1 0.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map nrxysin: ~A ~A" v0 v1))))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map nrxysin: ~A ~A" v0 v1))))
(if (not (nrxysin? gen)) (snd-display ";~A not nrxysin?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";nrxysin phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";nrxysin frequency: ~F?" (mus-frequency gen)))
@@ -13947,7 +13794,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(outa i (nrxysin gen)))))
- (if (not (vequal v1 (float-vector 0.000 0.671 0.637 0.186 0.017 0.169 0.202 0.048 0.007 0.105)))
+ (if (not (mus-arrays-equal? v1 (float-vector 0.000 0.671 0.637 0.186 0.017 0.169 0.202 0.048 0.007 0.105)))
(snd-display ";ws nrxysin output: ~A" v1)))
@@ -13962,7 +13809,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-nrxycos 440.0)))
(fill-float-vector v1 (if (nrxycos? gen1) (nrxycos gen1 0.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map nrxycos: ~A ~A" v0 v1))))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map nrxycos: ~A ~A" v0 v1))))
(if (not (nrxycos? gen)) (snd-display ";~A not nrxycos?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";nrxycos phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";nrxycos frequency: ~F?" (mus-frequency gen)))
@@ -13981,7 +13828,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(outa i (nrxycos gen)))))))
- (if (not (vequal v1 (float-vector 1.000 0.602 -0.067 -0.242 -0.007 0.071 -0.087 -0.128 -0.007 0.012)))
+ (if (not (mus-arrays-equal? v1 (float-vector 1.000 0.602 -0.067 -0.242 -0.007 0.071 -0.087 -0.128 -0.007 0.012)))
(snd-display ";ws nrxycos output: ~A" v1)))
(let ((gen (make-asymmetric-fm 440.0))
@@ -13995,7 +13842,7 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-asymmetric-fm 440.0)))
(fill-float-vector v1 (if (asymmetric-fm? gen1) (asymmetric-fm gen1 0.0) -1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map asymmetric-fm: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map asymmetric-fm: ~A ~A" v0 v1)))
(if (not (asymmetric-fm? gen)) (snd-display ";~A not asymmetric-fm?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";asymmetric-fm phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
@@ -14036,8 +13883,8 @@ EDITS: 2
(outa i (asymmetric-fm gen index))))))))
(if (> (abs (- peak 1.0)) .1)
(snd-display ";asymmetric-fm peak: ~A, index: ~A, r: ~A" peak index r))))
- (list -10.0 -1.5 -0.5 0.5 1.0 1.5 10.0)))
- (list 1.0 3.0 10.0))
+ '(-10.0 -1.5 -0.5 0.5 1.0 1.5 10.0)))
+ '(1.0 3.0 10.0))
(let ((float-vector0 (make-float-vector 2048))
(float-vector1 (make-float-vector 2048))
@@ -14066,19 +13913,19 @@ EDITS: 2
(r 1.0)
(ratio 0.1)
(index 2.0))
- (let ((cr (* 0.5 (- r (/ 1.0 r))))
- (sr (* 0.5 (+ r (/ 1.0 r)))))
- (do ((i 0 (+ i 1))
- (a 0.0 (+ a incr)))
- ((= i 1100))
- (let ((val1 (asymmetric-fm gen 2.0)) ; 1.0=index
- (val3 (asyfm-J gen1 0.0))
- (mth (* ratio a)))
- (let ((val2 (* (exp (* index cr (+ 1.0 (cos mth))))
- (cos (+ a (* index sr (sin mth)))))))
- (if (or (fneq val1 val2)
- (fneq val1 val3))
- (snd-display ";asyfm by hand: ~A: ~A ~A ~A" i val1 val2 val3)))))))
+ (do ((cr (* 0.5 (- r (/ 1.0 r))))
+ (sr (* 0.5 (+ r (/ 1.0 r))))
+ (i 0 (+ i 1))
+ (a 0.0 (+ a incr)))
+ ((= i 1100))
+ (let ((val1 (asymmetric-fm gen 2.0)) ; 1.0=index
+ (val3 (asyfm-J gen1 0.0))
+ (mth (* ratio a)))
+ (let ((val2 (* (exp (* index cr (+ 1.0 (cos mth))))
+ (cos (+ a (* index sr (sin mth)))))))
+ (if (or (fneq val1 val2)
+ (fneq val1 val3))
+ (snd-display ";asyfm by hand: ~A: ~A ~A ~A" i val1 val2 val3))))))
(let ((float-vector0 (make-float-vector 2048))
(float-vector1 (make-float-vector 2048))
@@ -14349,7 +14196,7 @@ EDITS: 2
(fill-float-vector v1 (let ((val (if (fir-filter? gen1) (fir-filter gen1 inp) -1.0)))
(set! inp 0.0)
val)))
- (if (not (vequal v0 v1)) (snd-display ";map fir-filter: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map fir-filter: ~A ~A" v0 v1)))
(if (not (fir-filter? gen)) (snd-display ";~A not fir-filter?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";fir-filter length: ~D?" (mus-length gen)))
(if (or (fneq (v0 1) 0.25) (fneq (v0 2) .125)) (snd-display ";fir-filter output: ~A" v0))
@@ -14418,20 +14265,20 @@ EDITS: 2
(snd-display ";make-spencer-filter returns ~A?" gen)
(begin
(if (not (= (mus-order gen) 15)) (snd-display ";make-spencer-filter order ~A?" (mus-order gen)))
- (if (not (vequal (mus-xcoeffs gen) (float-vector -0.009 -0.019 -0.016 0.009 0.066 0.144 0.209 0.231 0.209 0.144 0.066 0.009 -0.016 -0.019 -0.009)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs gen) (float-vector -0.009 -0.019 -0.016 0.009 0.066 0.144 0.209 0.231 0.209 0.144 0.066 0.009 -0.016 -0.019 -0.009)))
(snd-display ";make-spencer-filter coeffs: ~A" (mus-xcoeffs gen))))))
(let ((flt (make-savitzky-golay-filter 5 2)))
- (if (not (vequal (mus-xcoeffs flt) (float-vector -0.086 0.343 0.486 0.343 -0.086)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs flt) (float-vector -0.086 0.343 0.486 0.343 -0.086)))
(snd-display ";sg 5 2: ~A" (mus-xcoeffs flt))))
(let ((flt (make-savitzky-golay-filter 11 2)))
- (if (not (vequal (mus-xcoeffs flt) (float-vector -0.084 0.021 0.103 0.161 0.196 0.207 0.196 0.161 0.103 0.021 -0.084)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs flt) (float-vector -0.084 0.021 0.103 0.161 0.196 0.207 0.196 0.161 0.103 0.021 -0.084)))
(snd-display ";sg 11 2: ~A" (mus-xcoeffs flt))))
(let ((flt (make-savitzky-golay-filter 11 4)))
- (if (not (vequal (mus-xcoeffs flt) (float-vector 0.042 -0.105 -0.023 0.140 0.280 0.333 0.280 0.140 -0.023 -0.105 0.042)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs flt) (float-vector 0.042 -0.105 -0.023 0.140 0.280 0.333 0.280 0.140 -0.023 -0.105 0.042)))
(snd-display ";sg 11 4: ~A" (mus-xcoeffs flt))))
(let ((flt (make-savitzky-golay-filter 25 2)))
- (if (not (vequal (mus-xcoeffs flt) (float-vector -0.049 -0.027 -0.006 0.012 0.028 0.043 0.055 0.066 0.075 0.082 0.086
+ (if (not (mus-arrays-equal? (mus-xcoeffs flt) (float-vector -0.049 -0.027 -0.006 0.012 0.028 0.043 0.055 0.066 0.075 0.082 0.086
0.089 0.090 0.089 0.086 0.082 0.075 0.066 0.055 0.043
0.028 0.012 -0.006 -0.027 -0.049)))
(snd-display ";sg 25 2: ~A" (mus-xcoeffs flt))))
@@ -14452,7 +14299,7 @@ EDITS: 2
(fill-float-vector v1 (let ((val (if (iir-filter? gen1) (iir-filter gen1 inp) -1.0)))
(set! inp 0.0)
val)))
- (if (not (vequal v0 v1)) (snd-display ";map iir-filter: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map iir-filter: ~A ~A" v0 v1)))
(if (not (iir-filter? gen)) (snd-display ";~A not iir-filter?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";iir-filter length: ~D?" (mus-length gen)))
(if (or (fneq (v0 1) -0.25) (fneq (v0 2) -.062)) (snd-display ";iir-filter output: ~A" v0))
@@ -14482,13 +14329,13 @@ EDITS: 2
(do ((i 1 (+ i 1)))
((= i 10))
(set! (v0 i) (filter gen 0.0)))
- (let ((v1 (make-float-vector 10)))
- (let ((gen1 (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125))))
- (let ((inp 1.0))
- (fill-float-vector v1 (let ((val (if (filter? gen1) (filter gen1 inp) -1.0)))
- (set! inp 0.0)
- val))))
- (if (not (vequal v0 v1)) (snd-display ";map filter: ~A ~A" v0 v1)))
+ (let* ((v1 (make-float-vector 10))
+ (gen1 (make-filter 3 (float-vector .5 .25 .125) (float-vector .5 .25 .125)))
+ (inp 1.0))
+ (fill-float-vector v1 (let ((val (if (filter? gen1) (filter gen1 inp) -1.0)))
+ (set! inp 0.0)
+ val))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map filter: ~A ~A" v0 v1)))
(if (not (filter? gen)) (snd-display ";~A not filter?" gen))
(if (not (= (mus-length gen) 3)) (snd-display ";filter length: ~D?" (mus-length gen)))
(if (or (fneq (v0 1) 0.125) (fneq (v0 2) .031)) (snd-display ";filter output: ~A" v0))
@@ -14529,25 +14376,25 @@ EDITS: 2
(if (not (= (mus-length fr) 6)) (snd-display ";filter-length: ~A" (mus-length fr))))
(let ((val (cascade->canonical (list (float-vector 1.0 0.0 0.0) (float-vector 1.0 0.5 0.25)))))
- (if (not (vequal val (float-vector 1.000 0.500 0.250 0.000 0.000)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 0.500 0.250 0.000 0.000)))
(snd-display ";cas2can 0: ~A" val)))
(let ((val (cascade->canonical (list (float-vector 1.0 1.0 0.0) (float-vector 1.0 0.5 0.25)))))
- (if (not (vequal val (float-vector 1.000 1.500 0.750 0.250 0.000)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 1.500 0.750 0.250 0.000)))
(snd-display ";cas2can 1: ~A" val)))
(let ((val (cascade->canonical (list (float-vector 1 0.8 0) (float-vector 1 1.4 0.65) (float-vector 1 0 0)))))
- (if (not (vequal val (float-vector 1.000 2.200 1.770 0.520 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 2.200 1.770 0.520 0.000 0.000 0.000)))
(snd-display ";cascade->canonical: ~A" val)))
(let ((val (cascade->canonical (list (float-vector 1 -0.9 0) (float-vector 1 1 0.74) (float-vector 1 -1.6 0.8)))))
- (if (not (vequal val (float-vector 1.000 -1.500 0.480 -0.330 0.938 -0.533 0.000)))
+ (if (not (mus-arrays-equal? val (float-vector 1.000 -1.500 0.480 -0.330 0.938 -0.533 0.000)))
(snd-display ";cascade->canonical 1: ~A" val)))
(let ((ind (new-sound "test.snd" 1 22050 mus-ldouble mus-next)))
(pad-channel 0 10000)
(freq-sweep .45)
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.962 0.998 0.998 0.998 0.998 0.999 0.999 0.998 0.997 1.000))
- (vequal sp (float-vector 0.963 0.999 0.999 0.999 0.999 0.999 1.000 1.000 0.998 0.997))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.962 0.998 0.998 0.998 0.998 0.999 0.999 0.998 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.963 0.999 0.999 0.999 0.999 0.999 1.000 1.000 0.998 0.997))))
(snd-display ";initial rough spectrum: ~A" sp)))
(let ((b (make-butter-high-pass 440.0)))
@@ -14555,13 +14402,13 @@ EDITS: 2
(d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
+ (if (not (mus-arrays-equal? v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
(snd-display ";butter high: ~A" v)))
(set! b (make-butter-high-pass 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000))
- (vequal sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
(snd-display ";hp rough spectrum: ~A" sp)))
(undo))
@@ -14570,12 +14417,12 @@ EDITS: 2
(d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
+ (if (not (mus-arrays-equal? v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
(snd-display ";butter low: ~A" v)))
(set! b (make-butter-low-pass 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 1.000 0.212 0.024 0.005 0.001 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 1.000 0.212 0.024 0.005 0.001 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";lp rough spectrum: ~A" sp)))
(undo))
@@ -14584,12 +14431,12 @@ EDITS: 2
(d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.007 0.014 0.013 0.013 0.012 0.011 0.009 0.008 0.007 0.005)))
+ (if (not (mus-arrays-equal? v (float-vector 0.007 0.014 0.013 0.013 0.012 0.011 0.009 0.008 0.007 0.005)))
(snd-display ";butter bandpass: ~A" v)))
(set! b (make-butter-band-pass 1000.0 500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 0.888 1.000 0.144 0.056 0.027 0.014 0.008 0.004 0.002 0.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 0.888 1.000 0.144 0.056 0.027 0.014 0.008 0.004 0.002 0.000)))
(snd-display ";bp rough spectrum: ~A" sp)))
(undo))
@@ -14598,13 +14445,13 @@ EDITS: 2
(d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0)))
- (if (not (vequal v (float-vector 0.993 -0.014 -0.013 -0.013 -0.012 -0.011 -0.009 -0.008 -0.007 -0.005)))
+ (if (not (mus-arrays-equal? v (float-vector 0.993 -0.014 -0.013 -0.013 -0.012 -0.011 -0.009 -0.008 -0.007 -0.005)))
(snd-display ";butter bandstop: ~A" v)))
(set! b (make-butter-band-reject 1000.0 500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.662 0.687 0.953 0.980 0.989 0.994 0.997 0.997 0.997 1.000))
- (vequal sp (float-vector 0.664 0.689 0.955 0.982 0.992 0.996 0.999 1.000 0.999 0.998))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.662 0.687 0.953 0.980 0.989 0.994 0.997 0.997 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.664 0.689 0.955 0.982 0.992 0.996 0.999 1.000 0.999 0.998))))
(snd-display ";bs rough spectrum: ~A" sp)))
(undo))
@@ -14614,24 +14461,24 @@ EDITS: 2
(let ((v (spectrum->coeffs 10 (float-vector 0 1.0 0 0 0 0 0 0 1.0 0)))
(v1 (make-fir-coeffs 10 (float-vector 0 1.0 0 0 0 0 0 0 1.0 0))))
- (if (not (vequal v (float-vector -0.190 -0.118 0.000 0.118 0.190 0.190 0.118 0.000 -0.118 -0.190)))
+ (if (not (mus-arrays-equal? v (float-vector -0.190 -0.118 0.000 0.118 0.190 0.190 0.118 0.000 -0.118 -0.190)))
(snd-display ";spectrum->coeffs: ~A" v))
- (if (not (vequal v v1))
+ (if (not (mus-arrays-equal? v v1))
(snd-display ";spectrum->coeffs v make-fir-coeffs: ~A ~A" v v1)))
(let ((notched-spectr (make-float-vector 20)))
(set! (notched-spectr 2) 1.0)
(let ((v (spectrum->coeffs 20 notched-spectr))
(v1 (make-fir-coeffs 20 notched-spectr)))
- (if (not (vequal v (float-vector 0.095 0.059 -0.000 -0.059 -0.095 -0.095 -0.059 0.000 0.059 0.095
+ (if (not (mus-arrays-equal? v (float-vector 0.095 0.059 -0.000 -0.059 -0.095 -0.095 -0.059 0.000 0.059 0.095
0.095 0.059 0.000 -0.059 -0.095 -0.095 -0.059 -0.000 0.059 0.095)))
(snd-display ";spectrum->coeffs (notch): ~A" v))
- (if (not (vequal v v1))
+ (if (not (mus-arrays-equal? v v1))
(snd-display ";spectrum->coeffs v(2) make-fir-coeffs: ~A ~A" v v1))
(let ((flt (make-fir-filter 20 v)))
(map-channel (lambda (y) (fir-filter flt y))))))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 0.007 0.493 1.000 0.068 0.030 0.019 0.014 0.011 0.009 0.009)))
+ (if (not (mus-arrays-equal? sp (float-vector 0.007 0.493 1.000 0.068 0.030 0.019 0.014 0.011 0.009 0.009)))
(snd-display ";sp->coeff rough spectrum: ~A" sp)))
(undo)
@@ -14641,7 +14488,7 @@ EDITS: 2
(set! (rspect i) (random 1.0)))
(let ((v (spectrum->coeffs 20 rspect))
(v1 (make-fir-coeffs 20 rspect)))
- (if (not (vequal v v1))
+ (if (not (mus-arrays-equal? v v1))
(snd-display ";spectrum->coeffs v(3) make-fir-coeffs: ~A ~A" v v1))))
(let ((b (make-highpass (hz->radians 1000.0) 10)))
@@ -14649,14 +14496,14 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (fir-filter b 1.0))
(fill-float-vector v (delay d (fir-filter b 0.0))))
- (if (not (vequal v (float-vector -0.001 -0.002 -0.005 -0.011 -0.021 -0.034 -0.049 -0.065 -0.078 -0.087
+ (if (not (mus-arrays-equal? v (float-vector -0.001 -0.002 -0.005 -0.011 -0.021 -0.034 -0.049 -0.065 -0.078 -0.087
0.909 -0.087 -0.078 -0.065 -0.049 -0.034 -0.021 -0.011 -0.005 -0.002)))
(snd-display ";dsp.scm high: ~A" v)))
(set! b (make-highpass (hz->radians 1000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.053 0.774 0.998 0.997 0.997 0.996 0.996 0.996 0.997 1.000))
- (vequal sp (float-vector 0.053 0.776 1.000 0.998 0.998 0.998 0.998 0.998 0.998 1.000))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.053 0.774 0.998 0.997 0.997 0.996 0.996 0.996 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.053 0.776 1.000 0.998 0.998 0.998 0.998 0.998 0.998 1.000))))
(snd-display ";dsp hp rough spectrum: ~A" sp)))
(undo))
@@ -14665,13 +14512,13 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (fir-filter b 1.0))
(fill-float-vector v (delay d (fir-filter b 0.0))))
- (if (not (vequal v (float-vector 0.001 0.002 0.005 0.011 0.021 0.034 0.049 0.065 0.078 0.087 0.091 0.087 0.078 0.065
+ (if (not (mus-arrays-equal? v (float-vector 0.001 0.002 0.005 0.011 0.021 0.034 0.049 0.065 0.078 0.087 0.091 0.087 0.078 0.065
0.049 0.034 0.021 0.011 0.005 0.002)))
(snd-display ";dsp.scm low: ~A" v)))
(set! b (make-lowpass (hz->radians 1000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 1.000 0.054 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 1.000 0.054 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";dsp lp rough spectrum: ~A" sp)))
(undo))
@@ -14680,13 +14527,13 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (fir-filter b 1.0))
(fill-float-vector v (delay d (fir-filter b 0.0))))
- (if (not (vequal v (float-vector 0.001 -0.001 -0.005 -0.011 -0.017 -0.019 -0.013 0.003 0.022 0.039 0.045
+ (if (not (mus-arrays-equal? v (float-vector 0.001 -0.001 -0.005 -0.011 -0.017 -0.019 -0.013 0.003 0.022 0.039 0.045
0.039 0.022 0.003 -0.013 -0.019 -0.017 -0.011 -0.005 -0.001)))
(snd-display ";dsp.scm bp: ~A" v)))
(set! b (make-bandpass (hz->radians 1500.0) (hz->radians 2000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 0.010 1.000 0.154 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 0.010 1.000 0.154 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";dsp bp rough spectrum: ~A" sp)))
(undo))
@@ -14695,14 +14542,14 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (fir-filter b 1.0))
(fill-float-vector v (delay d (fir-filter b 0.0))))
- (if (not (vequal v (float-vector -0.001 0.001 0.005 0.011 0.017 0.019 0.013 -0.003 -0.022 -0.039 0.955
+ (if (not (mus-arrays-equal? v (float-vector -0.001 0.001 0.005 0.011 0.017 0.019 0.013 -0.003 -0.022 -0.039 0.955
-0.039 -0.022 -0.003 0.013 0.019 0.017 0.011 0.005 0.001)))
(snd-display ";dsp.scm bs: ~A" v)))
(set! b (make-bandstop (hz->radians 1500.0) (hz->radians 2000.0) 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.904 0.425 0.821 0.998 0.997 0.996 0.996 0.996 0.997 1.000))
- (vequal sp (float-vector 0.906 0.425 0.822 1.000 0.999 0.998 0.998 0.998 0.998 1.000))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.904 0.425 0.821 0.998 0.997 0.996 0.996 0.996 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.906 0.425 0.822 1.000 0.999 0.998 0.998 0.998 0.998 1.000))))
(snd-display ";dsp bs rough spectrum: ~A" sp)))
(undo))
@@ -14711,13 +14558,13 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (fir-filter b 1.0))
(fill-float-vector v (delay d (fir-filter b 0.0))))
- (if (not (vequal v (float-vector -0.008 0.011 -0.021 0.039 -0.066 0.108 -0.171 0.270 -0.456 0.977
+ (if (not (mus-arrays-equal? v (float-vector -0.008 0.011 -0.021 0.039 -0.066 0.108 -0.171 0.270 -0.456 0.977
0.000 -0.977 0.456 -0.270 0.171 -0.108 0.066 -0.039 0.021 -0.011)))
(snd-display ";dsp.scm df: ~A" v)))
(set! b (make-differentiator 20))
(map-channel (lambda (y) (fir-filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 0.004 0.027 0.075 0.147 0.242 0.362 0.506 0.674 0.864 1.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 0.004 0.027 0.075 0.147 0.242 0.362 0.506 0.674 0.864 1.000)))
(snd-display ";dsp df rough spectrum: ~A" sp)))
(undo))
@@ -14726,13 +14573,13 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (vequal v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
+ (if (not (mus-arrays-equal? v (float-vector 0.915 -0.162 -0.146 -0.131 -0.117 -0.103 -0.090 -0.078 -0.066 -0.056)))
(snd-display ";iir-2 high: ~A" v)))
(set! b (make-iir-high-pass-2 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000))
- (vequal sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.150 0.833 0.980 0.994 0.997 0.998 0.999 0.998 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.150 0.833 0.981 0.995 0.998 0.999 1.000 1.000 0.998 0.997))))
(snd-display ";iir-2 hp rough spectrum: ~A" sp)))
(undo))
@@ -14741,12 +14588,12 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (vequal v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
+ (if (not (mus-arrays-equal? v (float-vector 0.004 0.014 0.026 0.035 0.043 0.049 0.053 0.055 0.057 0.057)))
(snd-display ";iir-2 low: ~A" v)))
(set! b (make-iir-low-pass-2 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 1.000 0.212 0.024 0.005 0.001 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 1.000 0.212 0.024 0.005 0.001 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";iir-2 lp rough spectrum: ~A" sp)))
(undo))
@@ -14755,12 +14602,12 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (vequal v (float-vector 0.007 0.014 0.013 0.013 0.012 0.010 0.009 0.008 0.006 0.004)))
+ (if (not (mus-arrays-equal? v (float-vector 0.007 0.014 0.013 0.013 0.012 0.010 0.009 0.008 0.006 0.004)))
(snd-display ";iir bp-2 bandpass: ~A" v)))
(set! b (make-iir-band-pass-2 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (vequal sp (float-vector 0.239 1.000 0.117 0.041 0.019 0.010 0.005 0.003 0.001 0.000)))
+ (if (not (mus-arrays-equal? sp (float-vector 0.239 1.000 0.117 0.041 0.019 0.010 0.005 0.003 0.001 0.000)))
(snd-display ";iir bp-2 rough spectrum: ~A" sp)))
(undo))
@@ -14769,13 +14616,13 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (vequal v (float-vector 0.992 -0.017 -0.016 -0.015 -0.014 -0.012 -0.011 -0.009 -0.007 -0.005)))
+ (if (not (mus-arrays-equal? v (float-vector 0.992 -0.017 -0.016 -0.015 -0.014 -0.012 -0.011 -0.009 -0.007 -0.005)))
(snd-display ";iir-2 bandstop: ~A" v)))
(set! b (make-iir-band-stop-2 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.836 0.525 0.943 0.979 0.989 0.994 0.997 0.997 0.997 1.000))
- (vequal sp (float-vector 0.838 0.527 0.945 0.981 0.991 0.996 0.999 1.000 0.999 0.998))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.836 0.525 0.943 0.979 0.989 0.994 0.997 0.997 0.997 1.000))
+ (mus-arrays-equal? sp (float-vector 0.838 0.527 0.945 0.981 0.991 0.996 0.999 1.000 0.999 0.998))))
(snd-display ";iir bs-2 rough spectrum: ~A" sp)))
(undo))
@@ -14784,18 +14631,18 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (or (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.036 0.014 0.047 0.0685 0.0775))
- (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.015 0.049 0.070 0.081))
- (vequal v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.014 0.049 0.069 0.079))))
+ (if (not (or (mus-arrays-equal? v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.036 0.014 0.047 0.0685 0.0775))
+ (mus-arrays-equal? v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.015 0.049 0.070 0.081))
+ (mus-arrays-equal? v (float-vector 0.725 -0.466 -0.315 -0.196 -0.104 -0.035 0.014 0.049 0.069 0.079))))
(snd-display ";butter hp: ~A" v)))
(set! b (make-butter-hp 4 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 0.0505 0.982 1.000 1.000 0.998 0.998 0.999 0.998 0.996 0.999))
- (vequal sp (float-vector 0.051 0.982 1.000 1.000 0.998 0.998 0.998 0.999 0.997 0.995))
- (vequal sp (float-vector 0.051 0.991 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))
- (vequal sp (float-vector 0.045 0.970 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))
- (vequal sp (float-vector 0.052 0.971 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 0.0505 0.982 1.000 1.000 0.998 0.998 0.999 0.998 0.996 0.999))
+ (mus-arrays-equal? sp (float-vector 0.051 0.982 1.000 1.000 0.998 0.998 0.998 0.999 0.997 0.995))
+ (mus-arrays-equal? sp (float-vector 0.051 0.991 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))
+ (mus-arrays-equal? sp (float-vector 0.045 0.970 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))
+ (mus-arrays-equal? sp (float-vector 0.052 0.971 1.000 1.000 0.998 0.998 0.999 0.999 0.997 0.995))))
(snd-display ";bhp rough spectrum: ~A" sp)))
(undo))
@@ -14804,13 +14651,13 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))) ;; ???
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))) ;; ???
(snd-display ";butter lp: ~A" v)))
(set! b (make-butter-lp 4 1000.0))
(map-channel (lambda (y) (filter b y)))
(let ((sp (rough-spectrum ind)))
- (if (not (or (vequal sp (float-vector 1.000 0.035 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal sp (float-vector 1.000 0.038 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (if (not (or (mus-arrays-equal? sp (float-vector 1.000 0.035 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal? sp (float-vector 1.000 0.038 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";blp rough spectrum: ~A" sp)))
(undo))
@@ -14819,7 +14666,7 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";butter bp: ~A" v)))
(set! b (make-butter-bp 4 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
@@ -14830,9 +14677,9 @@ EDITS: 2
(let ((d (make-delay 1)))
(delay d (filter b 1.0))
(fill-float-vector v (delay d (filter b 0.0))))
- (if (not (or (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.026 -0.0225 -0.015 -0.0085))
- (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.022 -0.017 -0.011))
- (vequal v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.021 -0.014 -0.011))))
+ (if (not (or (mus-arrays-equal? v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.026 -0.0225 -0.015 -0.0085))
+ (mus-arrays-equal? v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.022 -0.017 -0.011))
+ (mus-arrays-equal? v (float-vector 0.978 -0.043 -0.041 -0.038 -0.035 -0.031 -0.027 -0.021 -0.014 -0.011))))
(snd-display ";butter bs: ~A" v)))
(set! b (make-butter-bs 4 1000.0 1500.0))
(map-channel (lambda (y) (filter b y)))
@@ -14853,7 +14700,7 @@ EDITS: 2
(let ((gen1 (make-sawtooth-wave 440.0))
(v1 (make-float-vector 10)))
(fill-float-vector v1 (if (sawtooth-wave? gen1) (sawtooth-wave gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map sawtooth: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map sawtooth: ~A ~A" v0 v1)))
(if (not (sawtooth-wave? gen)) (snd-display ";~A not sawtooth-wave?" gen))
(if (fneq (mus-phase gen) 4.39538) (snd-display ";sawtooth-wave phase: ~F?" (mus-phase gen))) ;starts at pi
(if (fneq (mus-frequency gen) 440.0) (snd-display ";sawtooth-wave frequency: ~F?" (mus-frequency gen)))
@@ -14892,7 +14739,7 @@ EDITS: 2
(set! w (mus-width gen1))
(if (square-wave? gen1) (square-wave gen1 0.0) -1.0)))
(if (fneq w 0.5) (snd-display ";mus-width opt: ~A" w))
- (if (not (vequal v0 v1)) (snd-display ";map square-wave: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map square-wave: ~A ~A" v0 v1)))
(if (not (square-wave? gen)) (snd-display ";~A not square-wave?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";square-wave phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";square-wave frequency: ~F?" (mus-frequency gen)))
@@ -14908,16 +14755,14 @@ EDITS: 2
(test-gen-equal (make-square-wave 440.0) (make-square-wave 440.0) (make-square-wave 440.0 1.0 1.0))
(test-gen-equal (make-square-wave 440.0) (make-square-wave 440.0) (make-square-wave 440.0 0.5))
- (let ((old-srate *clm-srate*))
- (set! *clm-srate* 500.0)
+ (let-temporarily ((*clm-srate* 500.0))
(let ((gen (make-square-wave 100.0 -0.5 (* pi 0.5)))
(v0 (make-float-vector 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(set! (v0 i) (gen)))
- (if (not (vequal v0 (float-vector -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5)))
- (snd-display ";square-wave -.5: ~A " v0)))
- (set! *clm-srate* old-srate))
+ (if (not (mus-arrays-equal? v0 (float-vector -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5 -0.5 -0.5 0.0 0.0 -0.5)))
+ (snd-display ";square-wave -.5: ~A " v0))))
(let ((gen (make-triangle-wave 440.0))
(v0 (make-float-vector 10)))
@@ -14930,7 +14775,7 @@ EDITS: 2
(let ((gen2 (make-triangle-wave 440.0))
(v1 (make-float-vector 10)))
(fill-float-vector v1 (if (triangle-wave? gen2) (triangle-wave gen2 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map triangle-wave: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map triangle-wave: ~A ~A" v0 v1)))
(if (not (triangle-wave? gen)) (snd-display ";~A not triangle-wave?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";triangle-wave phase: ~F?" (mus-phase gen)))
(let ((gen1 (make-triangle-wave 440.0 1.0 pi)))
@@ -14965,7 +14810,7 @@ EDITS: 2
(let ((gen1 (make-pulse-train 440.0))
(v1 (make-float-vector 10)))
(fill-float-vector v1 (if (pulse-train? gen1) (pulse-train gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map pulse-train: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map pulse-train: ~A ~A" v0 v1)))
(if (not (pulse-train? gen)) (snd-display ";~A not pulse-train?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";pulse-train phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";pulse-train frequency: ~F?" (mus-frequency gen)))
@@ -14978,17 +14823,14 @@ EDITS: 2
(test-gen-equal (make-pulse-train 440.0) (make-pulse-train 440.0) (make-pulse-train 440.0 1.0 1.0))
(test-gen-equal (make-pulse-train 440.0) (make-pulse-train 440.0) (make-pulse-train 440.0 0.5))
- (let ((old-srate *clm-srate*))
- (set! *clm-srate* 500.0)
+ (let-temporarily ((*clm-srate* 500.0))
(let ((gen (make-pulse-train 100.0 -0.5 (* pi 0.5)))
(v0 (make-float-vector 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(set! (v0 i) (gen)))
- (if (not (vequal v0 (float-vector 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5)))
- (snd-display ";pulse-train -.5: ~A " v0)))
- (set! *clm-srate* old-srate))
-
+ (if (not (mus-arrays-equal? v0 (float-vector 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5 0.0 0.0 0.0 0.0 -0.5)))
+ (snd-display ";pulse-train -.5: ~A " v0))))
(let ((gen (make-two-pole 1200.0 .1)))
(if (not (two-pole? gen)) (snd-display ";~A not 2-polar?" gen))
@@ -15041,7 +14883,7 @@ EDITS: 2
(fill-float-vector v1 (let ((val (if (formant? gen1) (formant gen1 inp) -1.0)))
(set! inp 0.0)
val))
- (if (not (vequal v0 v1)) (snd-display ";map formant: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map formant: ~A ~A" v0 v1)))
(if (not (formant? gen)) (snd-display ";~A not formant?" gen))
(if (not (= (mus-order gen) 2)) (snd-display ";formant order: ~D?" (mus-order gen)))
(if (fneq (mus-frequency gen) 1200.0) (snd-display ";formant frequency: ~F?" (mus-frequency gen)))
@@ -15078,7 +14920,7 @@ EDITS: 2
(set! (v0 i) (+ (* 0.5 (formant f0 val)) (* 0.25 (formant f1 val))))
(set! (v1 i) (formant-bank fs val))
(set! val 0.0))
- (if (not (vequal v0 v1)) (snd-display ";formant bank 1: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";formant bank 1: ~A ~A" v0 v1)))
(let ((fs (make-vector 2))
(amps (make-float-vector 2 1.0))
@@ -15090,7 +14932,7 @@ EDITS: 2
(set! (amps 0) 0.5)
(set! (amps 1) 0.25)
(fill-float-vector v (let ((res (formant-bank fs val))) (set! val 0.0) res))
- (if (not (vequal v (float-vector 0.368 0.095 -0.346 -0.091 -0.020))) (snd-display ";run formant-bank: ~A" v)))
+ (if (not (mus-arrays-equal? v (float-vector 0.368 0.095 -0.346 -0.091 -0.020))) (snd-display ";run formant-bank: ~A" v)))
(let ((ob (open-sound "oboe.snd")))
;; test courtesy of Anders Vinjar
@@ -15125,7 +14967,7 @@ EDITS: 2
(fill-float-vector v1 (let ((val (if (firmant? gen1) (firmant gen1 inp) -1.0)))
(set! inp 0.0)
val))
- (if (not (vequal v0 v1)) (snd-display ";map firmant: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map firmant: ~A ~A" v0 v1)))
(if (not (firmant? gen)) (snd-display ";~A not firmant?" gen))
(if (not (= (mus-order gen) 2)) (snd-display ";firmant order: ~D?" (mus-order gen)))
(if (fneq (mus-frequency gen) 1200.0) (snd-display ";firmant frequency: ~F?" (mus-frequency gen)))
@@ -15146,90 +14988,90 @@ EDITS: 2
(let ((f3 (make-firmant 1200.0 0.5))) (firmant f3 1.0) f3))
(let ((gen (make-fft-window hamming-window 16)))
- (if (not (vequal gen (float-vector 0.080 0.115 0.215 0.364 0.540 0.716 0.865 1.000 1.000 0.865 0.716 0.540 0.364 0.215 0.115 0.080)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.080 0.115 0.215 0.364 0.540 0.716 0.865 1.000 1.000 0.865 0.716 0.540 0.364 0.215 0.115 0.080)))
(snd-display ";hamming window: ~A" gen)))
(let ((gen (make-fft-window rectangular-window 16)))
- (if (not (vequal gen (float-vector 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
(snd-display ";rectangular window: ~A" gen)))
(let ((gen (make-fft-window hann-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
(snd-display ";hann window: ~A" gen)))
(let ((gen (make-fft-window welch-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.234 0.438 0.609 0.750 0.859 0.938 1.000 1.000 0.938 0.859 0.750 0.609 0.438 0.234 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.234 0.438 0.609 0.750 0.859 0.938 1.000 1.000 0.938 0.859 0.750 0.609 0.438 0.234 0.000)))
(snd-display ";welch window: ~A" gen)))
(let ((gen (make-fft-window connes-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.055 0.191 0.371 0.562 0.739 0.879 1.000 1.000 0.879 0.739 0.562 0.371 0.191 0.055 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.055 0.191 0.371 0.562 0.739 0.879 1.000 1.000 0.879 0.739 0.562 0.371 0.191 0.055 0.000)))
(snd-display ";connes window: ~A" gen)))
(let ((gen (make-fft-window parzen-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 1.000 1.000 0.750 0.625 0.500 0.375 0.250 0.125 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 1.000 1.000 0.750 0.625 0.500 0.375 0.250 0.125 0.000)))
(snd-display ";parzen window: ~A" gen)))
(let ((gen (make-fft-window bartlett-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 1.000 1.000 0.750 0.625 0.500 0.375 0.250 0.125 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 1.000 1.000 0.750 0.625 0.500 0.375 0.250 0.125 0.000)))
(snd-display ";bartlett window: ~A" gen)))
(let ((gen (make-fft-window blackman2-window 16)))
- (if (not (vequal gen (float-vector 0.005 0.020 0.071 0.177 0.344 0.558 0.775 1.000 1.000 0.775 0.558 0.344 0.177 0.071 0.020 0.005)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.005 0.020 0.071 0.177 0.344 0.558 0.775 1.000 1.000 0.775 0.558 0.344 0.177 0.071 0.020 0.005)))
(snd-display ";blackman2 window: ~A" gen)))
(let ((gen (make-fft-window blackman3-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.003 0.022 0.083 0.217 0.435 0.696 1.000 1.000 0.696 0.435 0.217 0.083 0.022 0.003 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.003 0.022 0.083 0.217 0.435 0.696 1.000 1.000 0.696 0.435 0.217 0.083 0.022 0.003 0.000)))
(snd-display ";blackman3 window: ~A" gen)))
(let ((gen (make-fft-window blackman4-window 16)))
- (if (not (vequal gen (float-vector 0.002 0.002 0.003 0.017 0.084 0.263 0.562 1.000 1.000 0.562 0.263 0.084 0.017 0.003 0.002 0.002)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.002 0.002 0.003 0.017 0.084 0.263 0.562 1.000 1.000 0.562 0.263 0.084 0.017 0.003 0.002 0.002)))
(snd-display ";blackman4 window: ~A" gen)))
(let ((gen (make-fft-window blackman5-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.003 0.022 0.097 0.280 0.574 1.000 1.000 0.574 0.280 0.097 0.022 0.003 0.000 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.003 0.022 0.097 0.280 0.574 1.000 1.000 0.574 0.280 0.097 0.022 0.003 0.000 0.000)))
(snd-display ";blackman5 window: ~A" gen)))
(let ((gen (make-fft-window blackman6-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.001 0.011 0.064 0.223 0.520 1.000 1.000 0.520 0.223 0.064 0.011 0.001 0.000 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.001 0.011 0.064 0.223 0.520 1.000 1.000 0.520 0.223 0.064 0.011 0.001 0.000 0.000)))
(snd-display ";blackman6 window: ~A" gen)))
(let ((gen (make-fft-window blackman7-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.000 0.006 0.042 0.177 0.471 1.000 1.000 0.471 0.177 0.042 0.006 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.000 0.006 0.042 0.177 0.471 1.000 1.000 0.471 0.177 0.042 0.006 0.000 0.000 0.000)))
(snd-display ";blackman7 window: ~A" gen)))
(let ((gen (make-fft-window blackman8-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.000 0.003 0.028 0.141 0.426 1.000 1.000 0.426 0.141 0.028 0.003 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.000 0.003 0.028 0.141 0.426 1.000 1.000 0.426 0.141 0.028 0.003 0.000 0.000 0.000)))
(snd-display ";blackman8 window: ~A" gen)))
(let ((gen (make-fft-window blackman9-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.000 0.001 0.018 0.112 0.385 1.000 1.000 0.385 0.112 0.018 0.001 0.000 0.000 -0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.000 0.001 0.018 0.112 0.385 1.000 1.000 0.385 0.112 0.018 0.001 0.000 0.000 -0.000)))
(snd-display ";blackman9 window: ~A" gen)))
(let ((gen (make-fft-window blackman10-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.000 0.001 0.012 0.089 0.349 1.000 1.000 0.349 0.089 0.012 0.001 0.000 0.000 -0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.000 0.001 0.012 0.089 0.349 1.000 1.000 0.349 0.089 0.012 0.001 0.000 0.000 -0.000)))
(snd-display ";blackman10 window: ~A" gen)))
(let ((gen (make-fft-window rv2-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.001 0.021 0.095 0.250 0.478 0.729 1.000 1.000 0.729 0.478 0.250 0.095 0.021 0.001 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.001 0.021 0.095 0.250 0.478 0.729 1.000 1.000 0.729 0.478 0.250 0.095 0.021 0.001 0.000)))
(snd-display ";rv2 window: ~A" gen)))
(let ((gen (make-fft-window rv3-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.003 0.029 0.125 0.330 0.622 1.000 1.000 0.622 0.330 0.125 0.029 0.003 0.000 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.003 0.029 0.125 0.330 0.622 1.000 1.000 0.622 0.330 0.125 0.029 0.003 0.000 0.000)))
(snd-display ";rv3 window: ~A" gen)))
(let ((gen (make-fft-window rv4-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.000 0.000 0.009 0.062 0.228 0.531 1.000 1.000 0.531 0.228 0.062 0.009 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.000 0.000 0.009 0.062 0.228 0.531 1.000 1.000 0.531 0.228 0.062 0.009 0.000 0.000 0.000)))
(snd-display ";rv4 window: ~A" gen)))
(let ((gen (make-fft-window exponential-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.087 0.181 0.283 0.394 0.515 0.646 0.944 0.944 0.646 0.515 0.394 0.283 0.181 0.087 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.087 0.181 0.283 0.394 0.515 0.646 0.944 0.944 0.646 0.515 0.394 0.283 0.181 0.087 0.000)))
(snd-display ";exponential window: ~A" gen)))
(let ((gen (make-fft-window riemann-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.139 0.300 0.471 0.637 0.784 0.900 1.000 1.000 0.900 0.784 0.637 0.471 0.300 0.139 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.139 0.300 0.471 0.637 0.784 0.900 1.000 1.000 0.900 0.784 0.637 0.471 0.300 0.139 0.000)))
(snd-display ";riemann window: ~A" gen)))
(let ((gen (make-fft-window kaiser-window 16 2.5)))
- (if (not (vequal gen (float-vector 0.304 0.426 0.550 0.670 0.779 0.871 0.941 1.000 1.000 0.941 0.871 0.779 0.670 0.550 0.426 0.304)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.304 0.426 0.550 0.670 0.779 0.871 0.941 1.000 1.000 0.941 0.871 0.779 0.670 0.550 0.426 0.304)))
(snd-display ";kaiser window: ~A" gen)))
(let ((gen (make-fft-window cauchy-window 16 2.5)))
- (if (not (vequal gen (float-vector 0.138 0.173 0.221 0.291 0.390 0.532 0.719 1.000 1.000 0.719 0.532 0.390 0.291 0.221 0.173 0.138)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.138 0.173 0.221 0.291 0.390 0.532 0.719 1.000 1.000 0.719 0.532 0.390 0.291 0.221 0.173 0.138)))
(snd-display ";cauchy window: ~A" gen)))
(let ((gen (make-fft-window poisson-window 16 2.5)))
- (if (not (vequal gen (float-vector 0.082 0.112 0.153 0.210 0.287 0.392 0.535 1.000 1.000 0.535 0.392 0.287 0.210 0.153 0.112 0.082)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.082 0.112 0.153 0.210 0.287 0.392 0.535 1.000 1.000 0.535 0.392 0.287 0.210 0.153 0.112 0.082)))
(snd-display ";poisson window: ~A" gen)))
(let ((gen (make-fft-window gaussian-window 16 1.0)))
- (if (not (vequal gen (float-vector 0.607 0.682 0.755 0.823 0.882 0.932 0.969 1.000 1.000 0.969 0.932 0.882 0.823 0.755 0.682 0.607)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.607 0.682 0.755 0.823 0.882 0.932 0.969 1.000 1.000 0.969 0.932 0.882 0.823 0.755 0.682 0.607)))
(snd-display ";gaussian window: ~A" gen)))
(let ((gen (make-fft-window tukey-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
(snd-display ";tukey window: ~A" gen)))
(let ((gen (make-fft-window hann-poisson-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.038 0.146 0.309 0.500 0.691 0.854 1.000 1.000 0.854 0.691 0.500 0.309 0.146 0.038 0.000)))
(snd-display ";tukey window: ~A" gen)))
(let ((gen (make-fft-window bohman-window 16)))
- (if (not (vequal gen (float-vector 0.000 0.006 0.048 0.151 0.318 0.533 0.755 1.000 1.000 0.755 0.533 0.318 0.151 0.048 0.006 0.000)))
+ (if (not (mus-arrays-equal? gen (float-vector 0.000 0.006 0.048 0.151 0.318 0.533 0.755 1.000 1.000 0.755 0.533 0.318 0.151 0.048 0.006 0.000)))
(snd-display ";bohman window: ~A" gen)))
(for-each
@@ -15247,7 +15089,7 @@ EDITS: 2
(let ((val (func ang)))
(set! (v2 i) val)
(set! (v2 j) val)))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";~A by hand:~%; mus: ~A~%; loc: ~A" name v1 v2)))))
(list
@@ -15449,46 +15291,46 @@ EDITS: 2
(catch #t
(lambda ()
(let ((gen (make-fft-window samaraki-window 16)))
- (if (not (vequal gen (float-vector 1.000 0.531 0.559 0.583 0.604 0.620 0.631 0.638 0.640 0.638 0.631 0.620 0.604 0.583 0.559 0.531)))
+ (if (not (mus-arrays-equal? gen (float-vector 1.000 0.531 0.559 0.583 0.604 0.620 0.631 0.638 0.640 0.638 0.631 0.620 0.604 0.583 0.559 0.531)))
(snd-display ";samaraki window: ~A" gen)))
(let ((gen (make-fft-window ultraspherical-window 16)))
- (if (not (vequal gen (float-vector 1.000 0.033 0.034 0.035 0.036 0.036 0.037 0.037 0.037 0.037 0.037 0.036 0.036 0.035 0.034 0.033)))
+ (if (not (mus-arrays-equal? gen (float-vector 1.000 0.033 0.034 0.035 0.036 0.036 0.037 0.037 0.037 0.037 0.037 0.036 0.036 0.035 0.034 0.033)))
(snd-display ";ultraspherical window: ~A" gen)))
(let ((gen (make-fft-window dolph-chebyshev-window 16)))
- (if (not (vequal gen (float-vector 1.000 0.033 0.034 0.035 0.036 0.036 0.037 0.037 0.037 0.037 0.037 0.036 0.036 0.035 0.034 0.033)))
+ (if (not (mus-arrays-equal? gen (float-vector 1.000 0.033 0.034 0.035 0.036 0.036 0.037 0.037 0.037 0.037 0.037 0.036 0.036 0.035 0.034 0.033)))
(snd-display ";dolph-chebyshev window: ~A" gen)))
(without-errors
(let ((gen (make-fft-window dolph-chebyshev-window 16 1.0)))
- (if (not (vequal gen (float-vector 1.000 0.274 0.334 0.393 0.446 0.491 0.525 0.546 0.553 0.546 0.525 0.491 0.446 0.393 0.334 0.274)))
+ (if (not (mus-arrays-equal? gen (float-vector 1.000 0.274 0.334 0.393 0.446 0.491 0.525 0.546 0.553 0.546 0.525 0.491 0.446 0.393 0.334 0.274)))
(snd-display ";dolph-chebyshev window: ~A" gen))))
(let ((val1 (make-fft-window ultraspherical-window 16 0.0 0.0))
(val2 (make-fft-window dolph-chebyshev-window 16 0.0)))
- (if (not (vequal val1 val2)) (snd-display ";ultra/dolph 0: ~A ~A" val1 val2)))
+ (if (not (mus-arrays-equal? val1 val2)) (snd-display ";ultra/dolph 0: ~A ~A" val1 val2)))
(let ((val1 (make-fft-window ultraspherical-window 16 0.0 1.0))
(val2 (make-fft-window samaraki-window 16 0.0)))
- (if (not (vequal val1 val2)) (snd-display ";ultra/sam 0: ~A ~A" val1 val2)))
+ (if (not (mus-arrays-equal? val1 val2)) (snd-display ";ultra/sam 0: ~A ~A" val1 val2)))
(let ((val1 (make-fft-window ultraspherical-window 16 0.5 0.0))
(val2 (make-fft-window dolph-chebyshev-window 16 0.5)))
- (if (not (vequal val1 val2)) (snd-display ";ultra/dolph 5: ~A ~A" val1 val2)))
+ (if (not (mus-arrays-equal? val1 val2)) (snd-display ";ultra/dolph 5: ~A ~A" val1 val2)))
(let ((val1 (make-fft-window ultraspherical-window 16 0.5 1.0))
(val2 (make-fft-window samaraki-window 16 0.5)))
- (if (not (vequal val1 val2)) (snd-display ";ultra/sam 5: ~A ~A" val1 val2)))
+ (if (not (mus-arrays-equal? val1 val2)) (snd-display ";ultra/sam 5: ~A ~A" val1 val2)))
(let ((val1 (dolph 16 1.0))
(val2 (make-fft-window dolph-chebyshev-window 16 1.0)))
- (if (not (vequal val1 val2)) (snd-display ";dolph/dolph 1: ~A ~A" val1 val2))))
+ (if (not (mus-arrays-equal? val1 val2)) (snd-display ";dolph/dolph 1: ~A ~A" val1 val2))))
(lambda args (snd-display ";new windows: ~A" args)))
(when (defined? 'gsl-eigenvectors)
(let ((win (make-dpss-window 16 .01)))
- (if (not (vequal win (float-vector 0.964 0.973 0.981 0.987 0.992 0.996 0.999 1.000 1.000 0.999 0.996 0.992 0.987 0.981 0.973 0.964)))
+ (if (not (mus-arrays-equal? win (float-vector 0.964 0.973 0.981 0.987 0.992 0.996 0.999 1.000 1.000 0.999 0.996 0.992 0.987 0.981 0.973 0.964)))
(snd-display ";make-dpss-window 16 .01: ~A" win)))
(let ((win (make-dpss-window 16 .1)))
- (if (not (vequal win (float-vector 0.090 0.193 0.332 0.494 0.664 0.818 0.936 1.000 1.000 0.936 0.818 0.664 0.494 0.332 0.193 0.090)))
+ (if (not (mus-arrays-equal? win (float-vector 0.090 0.193 0.332 0.494 0.664 0.818 0.936 1.000 1.000 0.936 0.818 0.664 0.494 0.332 0.193 0.090)))
(snd-display ";make-dpss-window 16 .1: ~A" win)))
(let ((win (make-dpss-window 32 .09)))
- (if (not (vequal win (float-vector 0.004 0.011 0.025 0.050 0.086 0.138 0.206 0.290 0.388 0.496 0.610 0.722 0.823 0.908 0.968 1.000
+ (if (not (mus-arrays-equal? win (float-vector 0.004 0.011 0.025 0.050 0.086 0.138 0.206 0.290 0.388 0.496 0.610 0.722 0.823 0.908 0.968 1.000
1.000 0.968 0.908 0.823 0.722 0.610 0.496 0.388 0.290 0.206 0.138 0.086 0.050 0.025 0.011 0.004)))
(snd-display ";make-dpss-window 32 .09: ~A" win)))
@@ -15498,13 +15340,13 @@ EDITS: 2
(lambda (beta)
(let ((win1 (make-dpss-window n beta))
(win2 (make-fft-window dpss-window n beta)))
- (if (not (vequal win1 win2))
+ (if (not (mus-arrays-equal? win1 win2))
(snd-display ";dpss-windows:~% ~A~% ~A" win1 win2))))
- (list .01 .07 .12 .2)))
- (list 16 32)))
+ '(.01 .07 .12 .2)))
+ '(16 32)))
(let ((win (make-papoulis-window 32)))
- (if (not (vequal win (float-vector 0.000 0.001 0.006 0.021 0.048 0.091 0.151 0.227 0.318 0.422 0.533 0.647 0.755 0.852 0.930 0.982
+ (if (not (mus-arrays-equal? win (float-vector 0.000 0.001 0.006 0.021 0.048 0.091 0.151 0.227 0.318 0.422 0.533 0.647 0.755 0.852 0.930 0.982
1.000 0.982 0.930 0.852 0.755 0.647 0.533 0.422 0.318 0.227 0.151 0.091 0.048 0.021 0.006 0.001)))
(snd-display ";make-papoulis-window 32: ~A" win)))
@@ -15512,9 +15354,9 @@ EDITS: 2
(lambda (n)
(let ((win1 (make-papoulis-window n))
(win2 (make-fft-window papoulis-window n)))
- (if (not (vequal win1 win2))
+ (if (not (mus-arrays-equal? win1 win2))
(snd-display ";papoulis-windows:~% ~A~% ~A" win1 win2))))
- (list 32 64 256))
+ '(32 64 256))
(let ((v0 (make-float-vector 10))
@@ -15536,7 +15378,7 @@ EDITS: 2
(set! off (mus-offset gen1))
(if (env? gen1) (env gen1) -1.0)))
(if (fneq off 0.0) (snd-display ";mus-offset opt: ~A" off))
- (if (not (vequal v0 v1)) (snd-display ";map env: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map env: ~A ~A" v0 v1)))
(if (or (fneq (v0 0) 0.0) (fneq (v0 1) .1) (fneq (v0 6) .4))
(snd-display ";~A output: ~A" gen v0))
(if (fneq (env-interp 1.6 gen) 0.2) (snd-display ";env-interp ~A at 1.6: ~F?" gen (env-interp 1.5 gen)))
@@ -15595,63 +15437,63 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
(snd-display ";simple ramp: ~A" v)))
(let* ((v (make-float-vector 10))
(e (make-env '(0 0 1 1) :base 0 :length 8)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
(snd-display ";simple ramp, base 0: ~A" v)))
(let* ((v (make-float-vector 10))
(e (make-env '(0 0 1 1 2 .5) :base 0 :length 8)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
(snd-display ";two-step, base 0: ~A" v)))
(let ((e (make-env '((0 0) (1 1)) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
(snd-display ";simple ramp embedded: ~A" v)))
(let ((e (make-env '(0 1 1 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
(snd-display ";simple ramp down: ~A" v)))
(let ((e (make-env '(0 0 1 1 2 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";simple pyr: ~A" v)))
(let ((e (make-env '((0 0) (1 1) (2 0)) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";simple pyr embedded: ~A" v)))
(let ((e (make-env '(0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5: ~A" v)))
(let ((e (make-env '((0 0) (1 1) (2 -.5)) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5 embedded: ~A" v)))
(let ((e (make-env '(0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5: ~A" v))))
(let ((v (make-float-vector 10)))
@@ -15659,45 +15501,45 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
(snd-display ";simple ramp: ~A" v)))
(let* ((v (make-float-vector 10))
(e (make-env (float-vector 0 0 1 1) :base 0 :length 8)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
(snd-display ";simple ramp, base 0: ~A" v)))
(let* ((v (make-float-vector 10))
(e (make-env (float-vector 0 0 1 1 2 .5) :base 0 :length 8)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
(snd-display ";two-step, base 0: ~A" v)))
(let ((e (make-env (float-vector 0 1 1 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
(snd-display ";simple ramp down: ~A" v)))
(let ((e (make-env (float-vector 0 0 1 1 2 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";simple pyr: ~A" v)))
(let ((e (make-env (float-vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5: ~A" v)))
(let ((e (make-env (float-vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5: ~A" v))))
(let ((v (make-float-vector 10)))
@@ -15705,45 +15547,45 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.000)))
(snd-display ";simple ramp: ~A" v)))
(let* ((v (make-float-vector 10))
(e (make-env (vector 0 0 1 1) :base 0 :length 8)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000)))
(snd-display ";simple ramp, base 0: ~A" v)))
(let* ((v (make-float-vector 10))
(e (make-env (vector 0 0 1 1 2 .5) :base 0 :length 8)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000 0.500 0.500)))
(snd-display ";two-step, base 0: ~A" v)))
(let ((e (make-env (vector 0 1 1 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 1.000 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.000)))
(snd-display ";simple ramp down: ~A" v)))
(let ((e (make-env (vector 0 0 1 1 2 0) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";simple pyr: ~A" v)))
(let ((e (make-env (vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5: ~A" v)))
(let ((e (make-env (vector 0 0 1 1 2 -.5) :length 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.625 0.250 -0.125 -0.500)))
(snd-display ";simple pyr -.5: ~A" v))))
(let ((e (make-env '(0 0 1 1) :length 10)))
@@ -15797,11 +15639,11 @@ EDITS: 2
(if (fneq val 3.0) (snd-display ";set mus-offset env: ~A" val)))
(let ((e (make-env '(0 0 1 1 2 0) :length 10))
- (v (make-float-vector 10 0.0)))
+ (v (make-float-vector 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";e set off 0: ~A" v))
(if (not (= (mus-length e) 10)) (snd-display ";e set off 0 len: ~A" (mus-length e)))
(if (fneq (mus-scaler e) 1.0) (snd-display ";e set off 0 scl: ~A" (mus-scaler e)))
@@ -15810,7 +15652,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.400 0.800 1.200 1.600 2.000 1.500 1.000 0.500 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.400 0.800 1.200 1.600 2.000 1.500 1.000 0.500 0.000)))
(snd-display ";e set off 1: ~A" v))
(if (not (= (mus-length e) 10)) (snd-display ";e set off 1 len: ~A" (mus-length e)))
(if (fneq (mus-scaler e) 2.0) (snd-display ";e set off 1 scl: ~A" (mus-scaler e)))
@@ -15819,7 +15661,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 1.000 1.400 1.800 2.200 2.600 3.000 2.500 2.000 1.500 1.000)))
+ (if (not (mus-arrays-equal? v (float-vector 1.000 1.400 1.800 2.200 2.600 3.000 2.500 2.000 1.500 1.000)))
(snd-display ";e set off 2: ~A" v))
(if (not (= (mus-length e) 10)) (snd-display ";e set off 2 len: ~A" (mus-length e)))
(if (fneq (mus-scaler e) 2.0) (snd-display ";e set off 2 scl: ~A" (mus-scaler e)))
@@ -15828,18 +15670,18 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 1.000 1.222 1.444 1.667 1.889 2.111 2.333 2.556 2.778 3.000)))
+ (if (not (mus-arrays-equal? v (float-vector 1.000 1.222 1.444 1.667 1.889 2.111 2.333 2.556 2.778 3.000)))
(snd-display ";e set off 3: ~A" v))
(if (not (= (mus-length e) 19)) (snd-display ";e set off 3 len: ~A" (mus-length e)))
(if (fneq (mus-scaler e) 2.0) (snd-display ";e set off 3 scl: ~A" (mus-scaler e)))
(if (fneq (mus-offset e) 1.0) (snd-display ";e set off 3 off: ~A" (mus-offset e))))
(let ((e (make-env (float-vector 0 0 1 1 2 0) :length 10))
- (v (make-float-vector 10 0.0)))
+ (v (make-float-vector 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (env e)))
- (if (not (vequal v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display ";e from float-vector: ~A" v)))
(let ((e1 (make-env '(0 0 1 1) :base 32.0 :length 11))
@@ -15905,8 +15747,8 @@ EDITS: 2
(do ((i 0 (+ i 1))) ((= i 11)) (set! (lv2 i) (env e1)))
(mus-reset e1)
(do ((i 0 (+ i 1))) ((= i 11)) (set! (lv3 i) (env e1)))
- (if (not (vequal lv1 lv3)) (snd-display ";mus-reset: ~A ~A?" lv1 lv3))
- (if (not (vequal lv2 (make-float-vector 11))) (snd-display ";mus-reset 1: ~A?" lv2)))
+ (if (not (mus-arrays-equal? lv1 lv3)) (snd-display ";mus-reset: ~A ~A?" lv1 lv3))
+ (if (not (mus-arrays-equal? lv2 (make-float-vector 11))) (snd-display ";mus-reset 1: ~A?" lv2)))
(set! gen (make-env '(0 0 1 1 2 0) :length 11))
(do ((i 0 (+ i 1))) ((= i 4)) (env gen))
@@ -15963,16 +15805,15 @@ EDITS: 2
(let ((var (catch #t (lambda () (make-env :envelope '(0 0 1 1 2 0 1) :duration 1.0)) (lambda args args))))
(if (not (eq? (car var) 'bad-type))
(snd-display ";make-env odd length env: ~A" var)))
- (let ((var (catch #t (lambda () (make-env :envelope (list "hi" 0 1 1 2 0) :duration 1.0)) (lambda args args))))
+ (let ((var (catch #t (lambda () (make-env :envelope '("hi" 0 1 1 2 0) :duration 1.0)) (lambda args args))))
(if (not (eq? (car var) 'wrong-type-arg))
(snd-display ";make-env env of non-number: ~A" var)))
;; env-any
- (define env-any-env '(0 0 1 1 2 0.25 3 1 4 0))
- (let* ((env-any-1 (lambda (e func)
+ (let* ((env-any-env '(0 0 1 1 2 0.25 3 1 4 0))
+ (env-any-1 (lambda (e func)
(let* ((pts (mus-data e))
- (mus-position mus-channels)
- (pt (min (* 2 (mus-position e)) (- (length pts) 4)))
+ (pt (min (* 2 (mus-channels e)) (- (length pts) 4)))
(val (/ (- (env e) (mus-offset e)) (mus-scaler e)))
(y0 (min (pts (+ pt 1)) (pts (+ pt 3))))
(y1 (max (pts (+ pt 1)) (pts (+ pt 3))))
@@ -15982,9 +15823,7 @@ EDITS: 2
(+ y0
(* (- y1 y0) new-val)))))))
(sine-env-1 (lambda (e)
- (env-any-1 e (lambda (y)
- (* 0.5 (+ 1.0 (sin (+ (* -0.5 pi)
- (* pi y)))))))))
+ (env-any-1 e (lambda (y) (* 0.5 (+ 1.0 (sin (* pi (- y 0.5)))))))))
(square-env-1 (lambda (e)
(env-any-1 e (lambda (y)
(* y y)))))
@@ -15999,141 +15838,137 @@ EDITS: 2
(let ((b (expts (modulo (mus-channels e) (length expts)))))
(/ (- (expt b y) 1.0) (- b 1.0))))))))
-
-
;; assume sine-env square-env blackman4-env and multi-exp-env are available from generators.scm (8)
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (sine-env e))))))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (sine-env e))))))
(val2 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (sine-env e))))))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (sine-env e))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (sine-env-1 e)))))))
- (if (not (vequal val1 val2))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (sine-env-1 e)))))))
+ (if (not (mus-arrays-equal? val1 val2))
(snd-display ";sine-env straight and run: ~%; ~A~%; ~A" val1 val2))
- (if (not (vequal val1 val3))
+ (if (not (mus-arrays-equal? val1 val3))
(snd-display ";sine-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (square-env e))))))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (square-env e))))))
(val2 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (square-env e))))))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (square-env e))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (square-env-1 e)))))))
- (if (not (vequal val1 val2))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (square-env-1 e)))))))
+ (if (not (mus-arrays-equal? val1 val2))
(snd-display ";square-env straight and run: ~%; ~A~%; ~A" val1 val2))
- (if (not (vequal val1 val3))
+ (if (not (mus-arrays-equal? val1 val3))
(snd-display ";square-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (blackman4-env e))))))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (blackman4-env e))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (blackman4-env-1 e)))))))
- (if (not (vequal val1 val3))
+ (let ((e (make-env env-any-env :length 20)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (blackman4-env-1 e)))))))
+ (if (not (mus-arrays-equal? val1 val3))
(snd-display ";blackman4-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20))
- (bases (float-vector 32.0 0.3 1.5)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (multi-expt-env e bases))))))
+ (let ((e (make-env env-any-env :length 20))
+ (bases (float-vector 32.0 0.3 1.5)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (multi-expt-env e bases))))))
(val2 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20))
- (bases (float-vector 32.0 0.3 1.5)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (multi-expt-env e bases))))))
+ (let ((e (make-env env-any-env :length 20))
+ (bases (float-vector 32.0 0.3 1.5)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (multi-expt-env e bases))))))
(val3 (with-sound ((make-float-vector 20))
- (let ((e (make-env env-any-env :length 20))
- (bases (float-vector 32.0 0.3 1.5)))
- (do ((i 0 (+ i 1)))
- ((= i 20))
- (outa i (multi-expt-env-1 e bases)))))))
- (if (not (vequal val1 val2))
+ (let ((e (make-env env-any-env :length 20))
+ (bases (float-vector 32.0 0.3 1.5)))
+ (do ((i 0 (+ i 1)))
+ ((= i 20))
+ (outa i (multi-expt-env-1 e bases)))))))
+ (if (not (mus-arrays-equal? val1 val2))
(snd-display ";multi-expt-env straight and run: ~%; ~A~%; ~A" val1 val2))
- (if (not (vequal val1 val3))
+ (if (not (mus-arrays-equal? val1 val3))
(snd-display ";multi-expt-env straight and scm: ~%; ~A~%; ~A" val1 val3)))
(let ((val1 (with-sound ((make-float-vector 220))
- (let ((e1 (make-env env-any-env :length 220))
- (e2 (make-env env-any-env :length 220)))
- (do ((i 0 (+ i 1)))
- ((= i 220))
- (outa i (env-any e1
- (lambda (y1)
- (* y1 (env-any e2
- (lambda (y2)
- y2))))))))))
+ (let ((e1 (make-env env-any-env :length 220))
+ (e2 (make-env env-any-env :length 220)))
+ (do ((i 0 (+ i 1)))
+ ((= i 220))
+ (outa i (env-any e1
+ (lambda (y1)
+ (* y1 (env-any e2
+ (lambda (y2)
+ y2))))))))))
(val2 (with-sound ((make-float-vector 220))
- (let ((e1 (make-env env-any-env :length 220))
- (e2 (make-env env-any-env :length 220)))
- (do ((i 0 (+ i 1)))
- ((= i 220))
- (outa i (env-any e1 ; try it with and without "declare"
- (lambda (y1)
- (* y1 (env-any e2
- (lambda (y2)
- y2)))))))))))
- (if (not (vequal val1 val2))
+ (let ((e1 (make-env env-any-env :length 220))
+ (e2 (make-env env-any-env :length 220)))
+ (do ((i 0 (+ i 1)))
+ ((= i 220))
+ (outa i (env-any e1 ; try it with and without "declare"
+ (lambda (y1)
+ (* y1 (env-any e2
+ (lambda (y2)
+ y2)))))))))))
+ (if (not (mus-arrays-equal? val1 val2))
(snd-display ";env-any recursive: ~%; ~A~%; ~A" val1 val2))))
-
+
(let ((ind (new-sound :size 20)))
(select-sound ind)
(map-channel (lambda (y) 1.0))
(bumpy)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.0 0.0 0.001 0.021 0.105 0.264 0.467 0.673 0.846 0.960 1.000 0.960 0.846 0.673 0.467 0.264 0.105 0.021 0.001 0.0)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 0.0 0.001 0.021 0.105 0.264 0.467 0.673 0.846 0.960 1.000 0.960 0.846 0.673 0.467 0.264 0.105 0.021 0.001 0.0)))
(snd-display ";bumpy: ~A" vals)))
(if (fneq (channel-lp-inf) 1.0) ; just a fancy name for maxamp
(snd-display ";channel-lp-inf: ~A" (channel-lp-inf)))
(linear-src-channel 2.0)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.001 0.105 0.467 0.846 1.000 0.846 0.467 0.105 0.001)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.001 0.105 0.467 0.846 1.000 0.846 0.467 0.105 0.001)))
(snd-display ";linear-src-channel: ~A" vals)))
- (let ((old-clip *clipping*))
- (set! *clipping* #t)
+ (let-temporarily ((*clipping* #t))
(save-sound-as "tst.snd")
(let ((fvals (file->floats "tst.snd"))
(vals (channel->float-vector)))
- (if (not (vequal vals fvals))
+ (if (not (mus-arrays-equal? vals fvals))
(snd-display ";file->floats: ~A ~A" vals fvals)))
(mus-sound-forget "tst.snd")
- (delete-file "tst.snd")
- (set! *clipping* old-clip))
+ (delete-file "tst.snd"))
(let ((hp (make-differentiator)))
(map-channel (lambda (y)
(differentiator hp y))))
@@ -16172,10 +16007,10 @@ EDITS: 2
(let ((v2 (make-float-vector 10)))
(let ((gen4 (make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1)))))
(fill-float-vector v2 (if (table-lookup? gen4) (table-lookup gen4 0.0) -1.0))
- (if (not (vequal v0 v2)) (snd-display ";map table-lookup: ~A ~A" v0 v2))
+ (if (not (mus-arrays-equal? v0 v2)) (snd-display ";map table-lookup: ~A ~A" v0 v2))
(set! gen4 (make-table-lookup 440.0 :wave (partials->wave (float-vector 1 1 2 1))))
(fill-float-vector v2 (table-lookup gen4)))
- (if (not (vequal v0 v2)) (snd-display ";map table-lookup (no fm): ~A ~A" v0 v2)))
+ (if (not (mus-arrays-equal? v0 v2)) (snd-display ";map table-lookup (no fm): ~A ~A" v0 v2)))
(if (not (table-lookup? gen)) (snd-display ";~A not table-lookup?" gen))
(if (not (float-vector? (mus-data gen))) (snd-display ";mus-data table-lookup: ~A" (mus-data gen)))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";table-lookup phase: ~F?" (mus-phase gen)))
@@ -16200,14 +16035,14 @@ EDITS: 2
(snd-display ";normalized partials?"))
(set! (mus-data gen) (phase-partials->wave (list 1 1 0 2 1 (* pi .5)) #f #t)))
- (let ((tag (catch #t (lambda () (phase-partials->wave (list 1 .3 2 .2))) (lambda args (car args)))))
+ (let ((tag (catch #t (lambda () (phase-partials->wave '(1 .3 2 .2))) (lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg)) (snd-display ";bad length arg to phase-partials->wave: ~A" tag)))
- (let ((tag (catch #t (lambda () (phase-partials->wave (list "hiho" .3 2 .2))) (lambda args (car args)))))
+ (let ((tag (catch #t (lambda () (phase-partials->wave '("hiho" .3 2 .2))) (lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg)) (snd-display ";bad harmonic arg to phase-partials->wave: ~A" tag)))
(let ((tag (catch #t (lambda () (phase-partials->wave (list))) (lambda args (car args)))))
(if (not (eq? tag 'no-data)) (snd-display ";nil list to phase-partials->wave: ~A" tag)))
- (let ((vals (phase-partials->wave (list 1 1 0) (make-float-vector 16) #f)))
+ (let ((vals (phase-partials->wave '(1 1 0) (make-float-vector 16) #f)))
(do ((i 0 (+ i 1)))
((= i 16))
(if (fneq (vals i) (sin (/ (* 2 pi i) 16)))
@@ -16240,9 +16075,9 @@ EDITS: 2
(make-table-lookup 440.0 :wave (partials->wave '(1 1 2 1)))
(make-table-lookup 440.0 :wave (partials->wave '(1 1 2 .5))))
(test-gen-equal (make-table-lookup-with-env 440.0 '(0 0 1 1))
- (make-table-lookup-with-env 440.0 (list 0 0 1 1))
+ (make-table-lookup-with-env 440.0 '(0 0 1 1))
(make-table-lookup-with-env 440.0 '(0 0 1 1 2 0)))
- (let ((tag (catch #t (lambda () (partials->wave (list .5 .3 .2))) (lambda args (car args)))))
+ (let ((tag (catch #t (lambda () (partials->wave '(.5 .3 .2))) (lambda args (car args)))))
(if (not (eq? tag 'bad-type)) (snd-display ";odd length arg to partials->wave: ~A" tag)))
(let ((hi (make-table-lookup :size 256)))
@@ -16304,10 +16139,10 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (table-lookup tbl1 (* .1 pi))))
- (if (not (or (vequal v vals)
+ (if (not (or (mus-arrays-equal? v vals)
(= type mus-interp-all-pass)
(and (= type mus-interp-none)
- (vequal v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000)))))
+ (mus-arrays-equal? v (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 1.000 1.000 1.000 1.000)))))
(snd-display ";tbl interp ~A: ~A" type v))
(if (not (= (mus-interp-type tbl1) type)) (snd-display ";tbl interp-type (~A): ~A" type (mus-interp-type tbl1)))))))
(list
@@ -16342,7 +16177,7 @@ EDITS: 2
(let ((v1 (with-sound ((make-float-vector size) :srate 44100) (test-tbl 0 size 200 1 1 1)))
(v2 (with-sound ((make-float-vector size) :srate 44100) (test-fm1 0 size 200 1 1 1))))
- (if (and (not (vequal v1 v2))
+ (if (and (not (mus-arrays-equal? v1 v2))
(> (float-vector-peak (float-vector-subtract! v1 v2)) .002))
(snd-display ";fm/tbl peak diff (1 1): ~A" (float-vector-peak (float-vector-subtract! v1 v2)))))
@@ -16352,7 +16187,7 @@ EDITS: 2
(index (random 0.1)))
(let ((v1 (with-sound ((make-float-vector size) :srate 44100) (test-tbl 0 size 20 1 ratio index)))
(v2 (with-sound ((make-float-vector size) :srate 44100) (test-fm1 0 size 20 1 ratio index))))
- (if (and (not (vequal v1 v2))
+ (if (and (not (mus-arrays-equal? v1 v2))
(> (float-vector-peak (float-vector-subtract! v1 v2)) .002))
(snd-display ";fm/tbl peak diff ~A ~A: ~A" ratio index (float-vector-peak (float-vector-subtract! v1 v2))))))))
@@ -16373,10 +16208,10 @@ EDITS: 2
(let ((v1 (make-float-vector 10)))
(let ((gen1 (make-polyshape 440.0)))
(fill-float-vector v1 (if (polyshape? gen1) (polyshape gen1 1.0 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map polyshape: ~A ~A" v0 v1))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map polyshape: ~A ~A" v0 v1))
(set! gen1 (make-polyshape 440.0 :coeffs (partials->polynomial '(1 1))))
(fill-float-vector v1 (polyshape gen1 1.0)))
- (if (not (vequal v0 v1)) (snd-display ";1 map polyshape: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";1 map polyshape: ~A ~A" v0 v1)))
(if (not (polyshape? gen)) (snd-display ";~A not polyshape?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";polyshape phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
@@ -16407,8 +16242,7 @@ EDITS: 2
(happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1100)))
- (let* ((a (mus-phase gen))
- (val1 (cos a))
+ (let* ((val1 (cos (mus-phase gen)))
(val2 (gen 1.0 0.0)))
(if (fneq val1 val2)
(begin
@@ -16420,8 +16254,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((or (not happy)
(= i 1100)))
- (let* ((a (mus-phase gen))
- (val1 (cos a))
+ (let* ((val1 (cos (mus-phase gen)))
(val2 (gen 1.0 0.0)))
(if (fneq val1 val2)
(begin
@@ -16432,8 +16265,7 @@ EDITS: 2
(happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1100)))
- (let* ((a (mus-phase gen))
- (val1 (* .5 (cos a)))
+ (let* ((val1 (* .5 (cos (mus-phase gen))))
(val2 (gen 0.5 0.0)))
(if (fneq val1 val2)
(begin
@@ -16493,10 +16325,10 @@ EDITS: 2
(float-vector 0.0 0.5 0.25 0.25)
(make-float-vector 100 0.01)
(make-float-vector 1000 0.001))
- (list 'one-cos
- 'three-cos
- 'hundred-cos
- 'thousand-cos))
+ '(one-cos
+ three-cos
+ hundred-cos
+ thousand-cos))
(for-each
(lambda (amps name)
@@ -16530,10 +16362,10 @@ EDITS: 2
(float-vector 0.0 0.5 0.25 0.25)
(make-float-vector 100 0.01)
(make-float-vector 1000 0.001))
- (list 'one-sin
- 'three-sin
- 'hundred-sin
- 'thousand-sin))
+ '(one-sin
+ three-sin
+ hundred-sin
+ thousand-sin))
(for-each
(lambda (camps samps name)
@@ -16577,10 +16409,10 @@ EDITS: 2
(float-vector 0.0 0.25 0.25 0.0)
(make-float-vector 100 .006)
(make-float-vector 1000 0.0005))
- (list 'one-tu
- 'three-tu
- 'hundred-tu
- 'thousand-tu))
+ '(one-tu
+ three-tu
+ hundred-tu
+ thousand-tu))
;; polywave
(let ((gen (make-polywave 440.0 :partials '(1 1) :type mus-chebyshev-first-kind))
@@ -16600,10 +16432,10 @@ EDITS: 2
(let ((gen1 (make-polywave 440.0))
(v1 (make-float-vector 10)))
(fill-float-vector v1 (if (polywave? gen1) (polywave gen1 0.0) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map polywave: ~A ~A" v0 v1))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map polywave: ~A ~A" v0 v1))
(set! gen1 (make-polywave 440.0 (float-vector 1 1)))
(fill-float-vector v1 (polywave gen1))
- (if (not (vequal v0 v1)) (snd-display ";1 map polywave: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";1 map polywave: ~A ~A" v0 v1)))
(if (not (polywave? gen)) (snd-display ";~A not polywave?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";polywave phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
@@ -16631,8 +16463,7 @@ EDITS: 2
(happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1100)))
- (let* ((a (mus-phase gen))
- (val1 (cos a))
+ (let* ((val1 (cos (mus-phase gen)))
(val2 (gen 0.0)))
(if (fneq val1 val2)
(begin
@@ -16643,8 +16474,7 @@ EDITS: 2
(happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1100)))
- (let* ((a (mus-phase gen))
- (val1 (cos a))
+ (let* ((val1 (cos (mus-phase gen)))
(val2 (gen 0.0)))
(if (fneq val1 val2)
(begin
@@ -16656,8 +16486,7 @@ EDITS: 2
(set! (mus-scaler gen) 0.5)
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1100)))
- (let* ((a (mus-phase gen))
- (val1 (* .5 (cos a)))
+ (let* ((val1 (* .5 (cos (mus-phase gen))))
(val2 (gen 0.0)))
(if (fneq val1 val2)
(begin
@@ -16682,9 +16511,9 @@ EDITS: 2
((= i 4410))
(float-vector-set! v1 i (+ (cos ph) (cos kph)))))
(float-vector-scale! v1 0.5)
- (if (not (vequal v0 v1))
+ (if (not (mus-arrays-equal? v0 v1))
(snd-display ";polywave ~D vs cos: ~A" k (float-vector-peak-and-location (float-vector-subtract! v0 v1)))))
- (list 2 19 20 29 30 39 40 60 100)))
+ '(2 19 20 29 30 39 40 60 100)))
(for-each
(lambda (n)
@@ -16699,7 +16528,7 @@ EDITS: 2
(begin
(set! happy #f)
(snd-display ";polywave ~A at ~A: ~A ~A" n i val1 val2)))))))
- (list 1 8 50 128))
+ '(1 8 50 128))
(for-each
(lambda (n)
@@ -16714,7 +16543,7 @@ EDITS: 2
(begin
(set! happy #f)
(snd-display ";polywave second ~A at ~A: ~A ~A" n i val1 val2)))))))
- (list 1 8 50 128))
+ '(1 8 50 128))
(for-each
(lambda (n)
@@ -16729,7 +16558,7 @@ EDITS: 2
(begin
(set! happy #f)
(snd-display ";polyshape ~A at ~A: ~A ~A" n i val1 val2)))))))
- (list 1 8 16))
+ '(1 8 16))
(for-each
(lambda (n)
@@ -16744,7 +16573,7 @@ EDITS: 2
(begin
(set! happy #f)
(snd-display ";polyshape second ~A at ~A: ~A ~A" n i val1 val2)))))))
- (list 1 8 16))
+ '(1 8 16))
(for-each
(lambda (n)
@@ -16758,7 +16587,7 @@ EDITS: 2
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
(snd-display ";polywave run ~A: ~A" n max-dist))))
- (list 1 3 30 200))
+ '(1 3 30 200))
(for-each
(lambda (n)
@@ -16772,7 +16601,7 @@ EDITS: 2
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
(snd-display ";polywave second run ~A: ~A" n max-dist))))
- (list 1 3 30 200))
+ '(1 3 30 200))
(for-each
(lambda (n)
@@ -16786,7 +16615,7 @@ EDITS: 2
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
(snd-display ";polyshape run ~A: ~A" n max-dist))))
- (list 1 3 25))
+ '(1 3 25))
(for-each
(lambda (n)
@@ -16800,12 +16629,12 @@ EDITS: 2
(set! max-dist (max max-dist (abs (- val1 val2))))))
(if (fneq max-dist 0.0)
(snd-display ";polyshape second run ~A: ~A" n max-dist))))
- (list 1 3 25))
+ '(1 3 25))
(let* ((gen (make-polywave 100.0 (list 1 .9 3 .1 4 0.0)))
(vals (mus-data gen)))
(if (not (and (float-vector? vals)
- (vequal vals (float-vector 0.000 0.900 0.000 0.100 0.00))))
+ (mus-arrays-equal? vals (float-vector 0.000 0.900 0.000 0.100 0.00))))
(snd-display ";polywave mus-data: ~A" vals)
(begin
(float-vector-set! (mus-data gen) 2 .1)
@@ -16831,8 +16660,7 @@ EDITS: 2
(do ((k 0 (+ k 2)))
((>= k (length cfs)))
(set! (cfs k) (/ k 2)))
- (let* ((p (make-polywave 100.0 cfs mus-chebyshev-second-kind))
- (val (polywave p)))
+ (let ((val (polywave (make-polywave 100.0 cfs mus-chebyshev-second-kind))))
(if (fneq val 0.1)
(snd-display ";polywave ~D order second 0-coeff: ~A" i val)))))
@@ -16842,8 +16670,7 @@ EDITS: 2
(do ((k 0 (+ k 2)))
((>= k (length cfs)))
(set! (cfs k) (/ k 2)))
- (let* ((p (make-polywave 100.0 cfs mus-chebyshev-first-kind))
- (val (polywave p)))
+ (let ((val (polywave (make-polywave 100.0 cfs mus-chebyshev-first-kind))))
(if (fneq val (* 0.1 i))
(snd-display ";polywave ~D order first 0-coeff: ~A" i val)))))
@@ -16868,7 +16695,7 @@ EDITS: 2
((= i 10))
(set! (v0 i) (wave-train gen 0.0)))
(fill-float-vector v1 (if (wave-train? gen1) (wave-train gen1) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map wave-train: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map wave-train: ~A ~A" v0 v1)))
(if (not (wave-train? gen)) (snd-display ";~A not wave-train?" gen))
(if (fneq (mus-phase gen) 0.0) (snd-display ";wave-train phase: ~F?" (mus-phase gen)))
(set! (mus-phase gen) 1.0)
@@ -16906,7 +16733,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (wave-train tbl1 0.0))) ;(wave-train tbl1 (/ (* 2 pi .2) 4))))
- (if (not (vequal v vals))
+ (if (not (mus-arrays-equal? v vals))
(snd-display ";wt tbl interp ~A: ~A ~A" type v (mus-describe tbl1)))
(if (not (= (mus-interp-type tbl1) type)) (snd-display ";wt tbl interp-type (~A): ~A" type (mus-interp-type tbl1)))))))
(list
@@ -16948,22 +16775,21 @@ EDITS: 2
(map-channel (lambda (y) (wave-train gen)))
(let ((mx (maxamp)))
(if (fneq mx 0.6) (snd-display ";wt 0 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.600)))
(snd-display ";wt 0 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300)))
(snd-display ";wt 0 data 85: ~A" (channel->float-vector 85 30)))
(undo)
- (let* ((table (make-float-vector 10 .1))
- (gen (make-wave-train 1000.0 :initial-phase pi :wave table))) ; initial-phase is confusing in this context!
+ (let ((gen (make-wave-train 1000.0 :initial-phase pi :wave (make-float-vector 10 .1)))) ; initial-phase is confusing in this context!
(map-channel (lambda (y) (wave-train gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";wt 1 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000)))
(let ((op *print-length*))
@@ -16972,57 +16798,53 @@ EDITS: 2
(set! *print-length* op)))
(undo)
- (let* ((table (make-float-vector 10 .1))
- (gen (make-wave-train 2000.0 :wave table)))
+ (let ((gen (make-wave-train 2000.0 :wave (make-float-vector 10 .1))))
(map-channel (lambda (y) (wave-train gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";wt 2 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100)))
(snd-display ";wt 2 data: ~A" (channel->float-vector 0 30)))
- (if (not (or (vequal (channel->float-vector 440 30)
+ (if (not (or (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100))
;; if double, round off is just enough different to cause an off-by-1 problem here (and below)
- (vequal (channel->float-vector 440 30)
+ (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100 0.100 0.100 0.100 0.100 0.100))))
(snd-display ";wt 2 data 440: ~A" (channel->float-vector 440 30)))
(undo)
- (let* ((table (make-float-vector 10 .1))
- (gen (make-wave-train 3000.0 :wave table)))
+ (let ((gen (make-wave-train 3000.0 :wave (make-float-vector 10 .1))))
(map-channel (lambda (y) (wave-train gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.2) (snd-display ";wt 3 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100 0.100
0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100 0.100)))
(snd-display ";wt 3 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.100 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100
0.100 0.200 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.100 0.100 0.100 0.100)))
(snd-display ";wt 3 data 440: ~A" (channel->float-vector 440 30)))
(undo)
- (let* ((table (make-float-vector 10 .1))
- (gen (make-wave-train 5000.0 :wave table)))
+ (let ((gen (make-wave-train 5000.0 :wave (make-float-vector 10 .1))))
(map-channel (lambda (y) (wave-train gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.3) (snd-display ";wt 4 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300
0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200 0.200)))
(snd-display ";wt 4 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.300 0.200 0.200 0.200
0.300 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.200 0.300 0.200 0.200 0.200 0.300 0.200)))
(snd-display ";wt 4 data 440: ~A" (channel->float-vector 440 30)))
(undo)
- (let* ((table (make-float-vector 10 .1))
- (gen (make-wave-train 1000.0 :wave table))
+ (let* ((gen (make-wave-train 1000.0 :wave (make-float-vector 10 .1)))
(base-freq (mus-frequency gen))
(e (make-env '(0 1 1 2) :length 1001)))
(map-channel
@@ -17032,23 +16854,22 @@ EDITS: 2
result))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";wt 5 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100)))
(snd-display ";wt 5 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.100)))
(snd-display ";wt 5 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 900 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 900 30)
(float-vector 0.100 0.000 0.000 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.100 0.100 0.100 0.100)))
(snd-display ";wt 5 data 900: ~A" (channel->float-vector 900 30)))
(undo)
- (let* ((table (make-float-vector 10 .1))
- (gen (make-wave-train 500.0 :wave table))
- (ctr 0))
+ (let ((gen (make-wave-train 500.0 :wave (make-float-vector 10 .1)))
+ (ctr 0))
(map-channel
(lambda (y)
(let ((result (wave-train gen)))
@@ -17060,18 +16881,18 @@ EDITS: 2
result))))
(let ((mx (maxamp)))
(if (fneq mx 0.704) (snd-display ";wt 6 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";wt 6 data: ~A" (channel->float-vector 0 30)))
- (if (not (or (vequal (channel->float-vector 440 30)
+ (if (not (or (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.000 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal (channel->float-vector 440 30)
+ (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.000 0.000 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.241 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";wt 6 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 900 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 900 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.639 0.639 0.639)))
(snd-display ";wt 6 data 900: ~A" (channel->float-vector 900 30)))
@@ -17097,7 +16918,7 @@ EDITS: 2
(if (string=? (mus-file-name gen1) "oboe.snd")
-1.0
1.0)))
- (if (not (vequal v0 v1)) (snd-display ";map readin: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map readin: ~A ~A" v0 v1)))
(if (not (readin? gen)) (snd-display ";~A not readin?" gen))
(if (not (mus-input? gen)) (snd-display ";~A not input?" gen))
(if (not (= (mus-length gen) 50828)) (snd-display ";readin length: ~A?" (mus-length gen)))
@@ -17221,8 +17042,6 @@ EDITS: 2
(if (not (mus-output? gen)) (snd-display ";~A not output?" gen))
(if (not (sample->file? gen)) (snd-display ";~A not sample->file?" gen))
(if (not (= (mus-length gen) *clm-file-buffer-size*)) (snd-display ";sample->file length: ~A?" (mus-length gen)))
- (let ((genx gen))
- (if (not (equal? genx gen)) (snd-display ";sample->file equal? ~A ~A" genx gen)))
(if (not (string=? (mus-file-name gen) "fmv.snd")) (snd-display ";sample->file mus-file-name: ~A" (mus-file-name gen)))
(do ((i 0 (+ i 1)))
((= i 100))
@@ -17260,17 +17079,17 @@ EDITS: 2
(x 0.0 (+ x 0.1)))
((= i 10))
(outa i x gen))
- (if (not (vequal gen (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9)))
+ (if (not (mus-arrays-equal? gen (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9)))
(snd-display ";outa->float-vector ramp: ~A" gen))
(do ((i 0 (+ i 1))
(x 0.0 (+ x 0.1)))
((= i 10))
(outa i x gen))
- (if (not (vequal gen (float-vector-scale! (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9) 2.0)))
+ (if (not (mus-arrays-equal? gen (float-vector-scale! (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9) 2.0)))
(snd-display ";outa->float-vector ramp 2: ~A" gen))
(if (not (= (mus-channels gen) 1)) (snd-display ";mus-channels float-vector: ~A" (mus-channels gen))))
- (let ((gen (make-float-vector (list 4 100) 0.0)))
+ (let ((gen (make-float-vector '(4 100))))
(do ((i 0 (+ i 1)))
((= i 10))
(outa i .1 gen)
@@ -17293,7 +17112,7 @@ EDITS: 2
(snd-display ";4-chan sd out/in[~A]: ~A ~A ~A ~A?" i (ina i gen) (inb i gen) (in-any i 2 gen) (in-any i 3 gen))))
(if (not (= (mus-channels gen) 4)) (snd-display ";mus-channels sd 4: ~A" (mus-channels gen))))
- (let ((gen (make-float-vector (list 4 100) 0.0)))
+ (let ((gen (make-float-vector '(4 100))))
(do ((i 0 (+ i 1)))
((= i 10))
(out-any i .1 0 gen)
@@ -17385,11 +17204,11 @@ EDITS: 2
(snd-display ";make-sample->file bad type: ~A" var)))
(let ((v (vector 1.0 0.5 0.25 0.125 0.0))
- (v1 (make-float-vector 5 0.0)))
+ (v1 (make-float-vector 5)))
(do ((i 0 (+ i 1)))
((= i 5))
(set! (v1 i) (in-any i 0 v)))
- (if (not (vequal v1 (float-vector 1.0 0.5 0.25 0.125 0.0)))
+ (if (not (mus-arrays-equal? v1 (float-vector 1.0 0.5 0.25 0.125 0.0)))
(snd-display ";vector in-any -> ~A?" v1)))
(let ((invals (make-float-vector 10)))
@@ -17400,7 +17219,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(outa i (ina i invals))))))
- (if (not (vequal result (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
+ (if (not (mus-arrays-equal? result (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
(snd-display ";ina from float-vector: ~A" result))))
(let ((invals (make-float-vector 10)))
@@ -17411,7 +17230,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(outa i (ina i invals))))))
- (if (not (vequal result (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
+ (if (not (mus-arrays-equal? result (float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900)))
(snd-display ";run ina from float-vector: ~A" result))))
(for-each close-sound (sounds))
@@ -17421,7 +17240,7 @@ EDITS: 2
(if (fneq (float-vector-peak vals) .1)
(snd-display ";locsig to float-vector fm-violin peak: ~A" (float-vector-peak vals))))
- (let* ((vals (with-sound ((make-float-vector (list 2 4410) 0.0))
+ (let* ((vals (with-sound ((make-float-vector '(2 4410)))
(fm-violin 0 .1 440 .1 :degree 30)))
(mxs (maxamp vals)))
(if (fneq mxs 0.0666)
@@ -17515,9 +17334,9 @@ EDITS: 2
(let ((ind (open-sound "fmv.snd")))
(let ((c0 (channel->float-vector 0 15 ind 0))
(c1 (channel->float-vector 0 15 ind 1)))
- (if (not (vequal c0 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.58 0.66 0.74 0.82 -0.1 -0.12 -0.14 -0.16 -0.18)))
+ (if (not (mus-arrays-equal? c0 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.58 0.66 0.74 0.82 -0.1 -0.12 -0.14 -0.16 -0.18)))
(snd-display ";continue-sample->file (0): ~A" c0))
- (if (not (vequal c1 (float-vector 0.0 0.01 0.02 0.03 0.04 0.05 0.05 0.05 0.05 0.05 -0.05 -0.06 -0.07 -0.08 -0.09)))
+ (if (not (mus-arrays-equal? c1 (float-vector 0.0 0.01 0.02 0.03 0.04 0.05 0.05 0.05 0.05 0.05 -0.05 -0.06 -0.07 -0.08 -0.09)))
(snd-display ";continue-sample->file (1): ~A" c1)))
(close-sound ind))
(delete-file "fmv.snd")
@@ -17588,9 +17407,9 @@ EDITS: 2
(let ((ind (open-sound "fmv.snd")))
(let ((c0 (channel->float-vector 0 15 ind 0))
(c1 (channel->float-vector 0 15 ind 1)))
- (if (not (vequal c0 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.58 0.66 0.74 0.82 -0.1 -0.12 -0.14 -0.16 -0.18)))
+ (if (not (mus-arrays-equal? c0 (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.58 0.66 0.74 0.82 -0.1 -0.12 -0.14 -0.16 -0.18)))
(snd-display ";continue-frample->file (0): ~A" c0))
- (if (not (vequal c1 (float-vector 0.0 0.01 0.02 0.03 0.04 0.05 0.05 0.05 0.05 0.05 -0.05 -0.06 -0.07 -0.08 -0.09)))
+ (if (not (mus-arrays-equal? c1 (float-vector 0.0 0.01 0.02 0.03 0.04 0.05 0.05 0.05 0.05 0.05 -0.05 -0.06 -0.07 -0.08 -0.09)))
(snd-display ";continue-frample->file (1): ~A" c1)))
(close-sound ind))
(delete-file "fmv.snd")
@@ -17911,54 +17730,51 @@ EDITS: 2
"locsig"
"locsig chans 2, outn: [0.667 0.333], interp: linear")
(if (not (locsig? gen)) (snd-display ";~A not locsig?" gen))
- (let ((gen3 gen1))
- (if (not (eq? gen1 gen3)) (snd-display ";locsig eq? ~A ~A" gen1 gen3))
- (if (not (equal? gen1 gen3)) (snd-display ";locsig equal? ~A ~A" gen1 gen3)))
(let ((gen2 (make-locsig 60.0 :channels 4)))
(if (eq? gen1 gen2) (snd-display ";locsig 1 eq? ~A ~A" gen1 gen2))
(if (equal? gen gen1) (snd-display ";locsig 2 equal? ~A ~A" gen gen1))
(if (equal? gen gen2) (snd-display ";locsig 3 equal? ~A ~A" gen gen2))
(if (or (fneq (locsig-ref gen 0) .667) (fneq (locsig-ref gen 1) .333))
(snd-display ";locsig ref: ~F ~F?" (locsig-ref gen 0) (locsig-ref gen 1)))
- (if (not (vequal (mus-data gen) (float-vector 0.667 0.333)))
+ (if (not (mus-arrays-equal? (mus-data gen) (float-vector 0.667 0.333)))
(snd-display ";locsig gen outn: ~A" (mus-data gen)))
- (if (not (vequal (mus-data gen1) (float-vector 0.333 0.667)))
+ (if (not (mus-arrays-equal? (mus-data gen1) (float-vector 0.333 0.667)))
(snd-display ";locsig gen2 outn: ~A" (mus-data gen1)))
- (if (not (vequal (mus-data gen2) (float-vector 0.333 0.667 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data gen2) (float-vector 0.333 0.667 0.000 0.000)))
(snd-display ";locsig gen2 outn: ~A" (mus-data gen2))))
(let ((gen200 (make-locsig 200.0 :channels 4)))
- (if (not (vequal (mus-data gen200) (float-vector 0.000 0.000 0.778 0.222)))
+ (if (not (mus-arrays-equal? (mus-data gen200) (float-vector 0.000 0.000 0.778 0.222)))
(snd-display ";locsig gen200 outn: ~A" (mus-data gen200))))
(locsig-set! gen 0 .25)
- (if (not (vequal (mus-data gen) (float-vector 0.250 0.333)))
+ (if (not (mus-arrays-equal? (mus-data gen) (float-vector 0.250 0.333)))
(snd-display ";locsig gen .25 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(locsig-set! gen 0 .5)
- (if (not (vequal (mus-data gen) (float-vector 0.500 0.333)))
+ (if (not (mus-arrays-equal? (mus-data gen) (float-vector 0.500 0.333)))
(snd-display ";locsig gen .5 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(set! gen (make-locsig 120.0 2.0 .1 :channels 4))
- (if (not (vequal (mus-data gen) (float-vector 0.000 0.333 0.167 0.000)))
+ (if (not (mus-arrays-equal? (mus-data gen) (float-vector 0.000 0.333 0.167 0.000)))
(snd-display ";locsig gen 120 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(set! gen (make-locsig 300.0 2.0 .1 :channels 4))
- (if (not (vequal (mus-data gen) (float-vector 0.167 0.000 0.000 0.333)))
+ (if (not (mus-arrays-equal? (mus-data gen) (float-vector 0.167 0.000 0.000 0.333)))
(snd-display ";locsig gen 300 outn: ~A" (mus-data gen)))
(locsig gen 0 1.0)
(move-locsig gen1 90.0 1.0)
- (if (not (vequal (mus-data gen1) (float-vector 0.000 1.000)))
+ (if (not (mus-arrays-equal? (mus-data gen1) (float-vector 0.000 1.000)))
(snd-display ";locsig gen1 90 outn: ~A" (mus-data gen1)))
(move-locsig gen1 0.0 1.0)
- (if (not (vequal (mus-data gen1) (float-vector 1.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data gen1) (float-vector 1.000 0.000)))
(snd-display ";locsig gen1 0 outn: ~A" (mus-data gen1)))
(move-locsig gen1 45.0 1.0)
- (if (not (vequal (mus-data gen1) (float-vector 0.500 0.500)))
+ (if (not (mus-arrays-equal? (mus-data gen1) (float-vector 0.500 0.500)))
(snd-display ";locsig gen1 45 outn: ~A" (mus-data gen1)))
(move-locsig gen1 135.0 2.0)
- (if (not (vequal (mus-data gen1) (float-vector 0.000 0.500)))
+ (if (not (mus-arrays-equal? (mus-data gen1) (float-vector 0.000 0.500)))
(snd-display ";locsig gen1 135 outn: ~A" (mus-data gen1)))
(move-locsig gen1 -270.0 3.0)
- (if (not (vequal (mus-data gen1) (float-vector 0.333 0.0)))
+ (if (not (mus-arrays-equal? (mus-data gen1) (float-vector 0.333 0.0)))
(snd-display ";locsig gen1 -270 outn: ~A" (mus-data gen1))))
(for-each
@@ -17979,13 +17795,12 @@ EDITS: 2
(copy data last)
(if (> diff .25)
(format () ";locsig, increment ~F with deg ~F~%" diff x))))))
- (list 1 2 4 5 8))
+ '(1 2 4 5 8))
(for-each
(lambda (chans)
(let ((m1 (make-locsig :channels chans)))
- (if (not (and (= (mus-channels m1) chans)
- (= (mus-length m1) chans)))
+ (if (not (= (mus-channels m1) chans (mus-length m1)))
(snd-display ";locsig ~A chans but: ~A ~A" chans (mus-channels m1) (mus-length m1)))
(do ((i 0 (+ i 1)))
((= i chans))
@@ -17994,7 +17809,7 @@ EDITS: 2
((= i chans))
(if (fneq (locsig-ref m1 i) (* i .1))
(snd-display ";locsig[~A] = ~A (~A)?" i (locsig-ref m1 i) (* i .1))))))
- (list 1 2 4 8))
+ '(1 2 4 8))
(let ((var (catch #t (lambda () (make-locsig :channels 0)) (lambda args args))))
(if (not (eq? (car var) 'mus-error))
@@ -18033,38 +17848,38 @@ EDITS: 2
(let ((locs (make-locsig :channels 8 :degree 0)))
(move-locsig locs 180 1.0)
(if (fneq (locsig-ref locs 0) 0.0) (snd-display ";move-locsig by jump: ~A" (mus-data locs)))
- (if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 0.000 0.000 0.000 0.000 1.000 0.000 0.000 0.000)))
(snd-display ";move-locsig by jump data: ~A" (mus-data locs)))
(move-locsig locs 120.0 1.0)
- (if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.333 0.667 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 0.000 0.000 0.333 0.667 0.000 0.000 0.000 0.000)))
(snd-display ";move-locsig by jump 120 data: ~A" (mus-data locs)))
(move-locsig locs -20.0 1.0)
- (if (not (vequal (mus-data locs) (float-vector 0.556 0.000 0.000 0.000 0.000 0.000 0.000 0.444)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 0.556 0.000 0.000 0.000 0.000 0.000 0.000 0.444)))
(snd-display ";move-locsig by jump -20 data: ~A" (mus-data locs))))
(let ((sf (make-sample->file "fmv4.snd" 8 mus-bshort mus-next "this is a comment"))
(sfrev (make-sample->file "fmv4.reverb" 8 mus-bshort mus-next "this is a comment")))
(let ((locs (make-locsig :channels 8 :degree 0 :distance 1.0 :reverb 0.1
:output sf :revout sfrev :type mus-interp-linear)))
- (if (not (vequal (mus-data locs) (float-vector 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";ws not move-locsig by jump data: ~A" (mus-data locs)))
- (if (not (vequal (mus-xcoeffs locs) (float-vector 0.100 0.000 0.000 0.000 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs locs) (float-vector 0.100 0.000 0.000 0.000 0.0 0.0 0.0 0.0)))
(snd-display ";ws not move-locsig by jump rev data: ~A" (mus-xcoeffs locs)))
(move-locsig locs 180 2.0)
(if (fneq (locsig-ref locs 0) 0.0) (snd-display ";ws move-locsig by jump: ~A" (mus-data locs)))
- (if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000)))
(snd-display ";ws move-locsig by jump data: ~A" (mus-data locs)))
- (if (not (vequal (mus-xcoeffs locs) (float-vector 0.000 0.000 0.000 0.000 0.071 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs locs) (float-vector 0.000 0.000 0.000 0.000 0.071 0.000 0.000 0.000)))
(snd-display ";ws move-locsig by jump rev data: ~A" (mus-xcoeffs locs)))
(move-locsig locs 120.0 3.0)
- (if (not (vequal (mus-data locs) (float-vector 0.000 0.000 0.111 0.222 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 0.000 0.000 0.111 0.222 0.000 0.000 0.000 0.000)))
(snd-display ";ws move-locsig by jump 120 data: ~A" (mus-data locs)))
- (if (not (vequal (mus-xcoeffs locs) (float-vector 0.000 0.000 0.019 0.038 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs locs) (float-vector 0.000 0.000 0.019 0.038 0.000 0.000 0.000 0.000)))
(snd-display ";ws move-locsig by jump 120 rev data: ~A" (mus-xcoeffs locs)))
(move-locsig locs -20.0 4.0)
- (if (not (vequal (mus-data locs) (float-vector 0.139 0.000 0.000 0.000 0.000 0.000 0.000 0.111)))
+ (if (not (mus-arrays-equal? (mus-data locs) (float-vector 0.139 0.000 0.000 0.000 0.000 0.000 0.000 0.111)))
(snd-display ";ws move-locsig by jump -20 data: ~A" (mus-data locs)))
- (if (not (vequal (mus-xcoeffs locs) (float-vector 0.028 0.000 0.000 0.000 0.000 0.000 0.000 0.022)))
+ (if (not (mus-arrays-equal? (mus-xcoeffs locs) (float-vector 0.028 0.000 0.000 0.000 0.000 0.000 0.000 0.022)))
(snd-display ";ws move-locsig by jump -20 rev data: ~A" (mus-xcoeffs locs))))
(mus-close sf)
(mus-close sfrev))
@@ -18157,7 +17972,7 @@ EDITS: 2
(print-and-check (make-locsig -40 :channels 2)
"locsig"
"locsig chans 2, outn: [1.000 0.000], interp: linear")
- (print-and-check (make-locsig 160 :channels 4 :output (make-float-vector (list 4 10) 0.0))
+ (print-and-check (make-locsig 160 :channels 4 :output (make-float-vector '(4 10)))
"locsig"
"locsig chans 4, outn: [0.000 0.222 0.778 0.000], interp: linear")
(print-and-check (make-locsig 0 :channels 1 :output (make-float-vector 10))
@@ -18172,37 +17987,37 @@ EDITS: 2
(set! (dat i) (locsig-ref gen i)))
dat)))
(gen (make-locsig -.1 :channels 8)))
- (if (not (vequal (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
(snd-display ";locsig -.1(8): ~A" (locsig-data gen)))
(set! gen (make-locsig -359.9 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.998 0.002 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.998 0.002 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";locsig -359.9(8): ~A" (locsig-data gen)))
(set! gen (make-locsig -359.9 :channels 4))
- (if (not (vequal (locsig-data gen) (float-vector 0.999 0.001 0.000 0.000)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.999 0.001 0.000 0.000)))
(snd-display ";locsig -359.9(4): ~A" (locsig-data gen)))
(set! gen (make-locsig -360.1 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.998 0.000 0.000 0.000 0.000 0.000 0.000 0.002)))
(snd-display ";locsig -360.1(8): ~A" (locsig-data gen)))
(set! gen (make-locsig -700 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.556 0.444 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.556 0.444 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";locsig -700(8): ~A" (locsig-data gen)))
(set! gen (make-locsig -700 :channels 2))
- (if (not (vequal (locsig-data gen) (float-vector 1.000 0.000)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 1.000 0.000)))
(snd-display ";locsig -700(2): ~A" (locsig-data gen)))
(set! gen (make-locsig 20 :channels 2))
- (if (not (vequal (locsig-data gen) (float-vector 0.778 0.222)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.778 0.222)))
(snd-display ";locsig 20(2): ~A" (locsig-data gen)))
(set! gen (make-locsig 123456.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
(snd-display ";locsig 123456(8): ~A" (locsig-data gen)))
(set! gen (make-locsig 336.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.467 0.000 0.000 0.000 0.000 0.000 0.000 0.533)))
(snd-display ";locsig 336(8): ~A" (locsig-data gen)))
(set! gen (make-locsig -123456.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";locsig -123456(8): ~A" (locsig-data gen)))
(set! gen (make-locsig 24.0 :channels 8))
- (if (not (vequal (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (locsig-data gen) (float-vector 0.467 0.533 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";locsig 24(8): ~A" (locsig-data gen))))
(for-each
@@ -18265,7 +18080,7 @@ EDITS: 2
(locsig-reverb-ref gen i)
(* sq (revs i)))
(set! happy #f)))))))
- (list 0.0 45.0 90.0 1234.0))
+ '(0.0 45.0 90.0 1234.0))
(for-each
(lambda (ltype)
@@ -18274,7 +18089,7 @@ EDITS: 2
(let ((gen (make-locsig deg :channels 1 :type ltype)))
(if (not (= (mus-channels gen) 1)) (snd-display ";locsig ~A: ~A" deg gen))
(if (fneq (locsig-ref gen 0) 1.0) (snd-display ";locsig[~A] scaler ~A: ~A" ltype deg (locsig-ref gen 0)))))
- (list 0.0 45.0 90.0 1234.0)))
+ '(0.0 45.0 90.0 1234.0)))
(list mus-interp-linear mus-interp-sinusoidal))
(for-each
@@ -18301,8 +18116,8 @@ EDITS: 2
(locsig-reverb-ref gen i)
(* .1 (revs i)))
(set! happy #f))))))))
- (list 0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
- (list 2 3 4 5 8 12 16 24))
+ '(0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
+ '(2 3 4 5 8 12 16 24))
(for-each
(lambda (chans)
@@ -18330,51 +18145,51 @@ EDITS: 2
(locsig-reverb-ref gen i)
(* .1 (revs i)))
(set! happy #f))))))))
- (list 0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
+ '(0.0 45.0 90.0 120.0 180.0 275.0 315.0 300.0 15.0 1234.0)))
(list mus-interp-linear mus-interp-sinusoidal)))
- (list 2 3 4 5 8 12 16 24))
+ '(2 3 4 5 8 12 16 24))
))
(list mus-interp-linear mus-interp-sinusoidal))
(if revfile (mus-close revfile))))
- (list 0 1 2 4))
+ '(0 1 2 4))
(set! (locsig-type) mus-interp-linear)
- (let* ((outp (make-float-vector (list 1 10) 0.0))
+ (let* ((outp (make-float-vector '(1 10)))
(gen (make-locsig 0.0 :output outp)))
(if (not (= (mus-channels gen) 1)) (snd-display ";make-locsig->sd chans (1): ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
- (if (not (vequal (outp 0) (make-float-vector 10 1.0)))
+ (if (not (mus-arrays-equal? (outp 0) (make-float-vector 10 1.0)))
(snd-display ";locsig->sd chan 0: ~A" (outp 0))))
- (let* ((outp (make-float-vector (list 2 10) 0.0))
+ (let* ((outp (make-float-vector '(2 10)))
(gen (make-locsig 0.0 :output outp)))
(if (not (= (mus-channels gen) 2)) (snd-display ";make-locsig->sd chans: ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
- (if (not (vequal (outp 0) (make-float-vector 10 1.0)))
+ (if (not (mus-arrays-equal? (outp 0) (make-float-vector 10 1.0)))
(snd-display ";locsig->sd chan 0: ~A" (outp 0)))
- (if (not (vequal (outp 1) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (outp 1) (make-float-vector 10)))
(snd-display ";locsig->sd chan 1: ~A" (outp 1))))
- (let* ((outp (make-float-vector (list 2 10) 0.0))
+ (let* ((outp (make-float-vector '(2 10)))
(gen (make-locsig 45.0 :output outp)))
(if (not (= (mus-channels gen) 2)) (snd-display ";make-locsig->sd chans: ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
- (if (not (vequal (outp 0) (make-float-vector 10 0.5)))
+ (if (not (mus-arrays-equal? (outp 0) (make-float-vector 10 0.5)))
(snd-display ";locsig->sd chan 0 (0.5): ~A (~A)" (outp 0) gen))
- (if (not (vequal (outp 1) (make-float-vector 10 0.5)))
+ (if (not (mus-arrays-equal? (outp 1) (make-float-vector 10 0.5)))
(snd-display ";locsig->sd chan 1 (0.5): ~A" (outp 1)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 0.5))
- (if (not (vequal (outp 0) (make-float-vector 10 0.75)))
+ (if (not (mus-arrays-equal? (outp 0) (make-float-vector 10 0.75)))
(snd-display ";locsig->sd chan 0 (0.75) (~A): ~A" (outp 0) gen))
- (if (not (vequal (outp 1) (make-float-vector 10 0.75)))
+ (if (not (mus-arrays-equal? (outp 1) (make-float-vector 10 0.75)))
(snd-display ";locsig->sd chan 1 (0.75): ~A" (outp 1))))
(let* ((outp (make-float-vector 10))
@@ -18383,12 +18198,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
- (if (not (vequal outp (make-float-vector 10 1.0)))
+ (if (not (mus-arrays-equal? outp (make-float-vector 10 1.0)))
(snd-display ";locsig->float-vector chan 0: ~A" outp))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 0.5))
- (if (not (vequal outp (make-float-vector 10 1.5)))
+ (if (not (mus-arrays-equal? outp (make-float-vector 10 1.5)))
(snd-display ";locsig->float-vector chan 0: ~A" outp)))
(let* ((outp (make-float-vector 10))
@@ -18397,27 +18212,27 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
- (if (not (vequal outp (make-float-vector 10 0.5)))
+ (if (not (mus-arrays-equal? outp (make-float-vector 10 0.5)))
(snd-display ";locsig(2)->float-vector chan 0: ~A" outp))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 0.5))
- (if (not (vequal outp (make-float-vector 10 0.75)))
+ (if (not (mus-arrays-equal? outp (make-float-vector 10 0.75)))
(snd-display ";locsig(2)->float-vector chan 0: ~A" outp)))
- (let* ((outp (make-float-vector (list 4 10) 0.0))
+ (let* ((outp (make-float-vector '(4 10)))
(gen (make-locsig 135.0 :output outp)))
(if (not (= (mus-channels gen) 4)) (snd-display ";make-locsig->sd chans (4): ~A" (mus-channels gen)))
(do ((i 0 (+ i 1)))
((= i 10))
(locsig gen i 1.0))
- (if (not (vequal (outp 0) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (outp 0) (make-float-vector 10)))
(snd-display ";locsig(4)->sd chan 0 (0.5): ~A" (outp 0)))
- (if (not (vequal (outp 1) (make-float-vector 10 0.5)))
+ (if (not (mus-arrays-equal? (outp 1) (make-float-vector 10 0.5)))
(snd-display ";locsig(4)->sd chan 1 (0.5) (~A): ~A" (outp 1) gen))
- (if (not (vequal (outp 2) (make-float-vector 10 0.5)))
+ (if (not (mus-arrays-equal? (outp 2) (make-float-vector 10 0.5)))
(snd-display ";locsig(4)->sd chan 2 (0.5): ~A" (outp 2)))
- (if (not (vequal (outp 3) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (outp 3) (make-float-vector 10)))
(snd-display ";locsig(4)->sd chan 3 (0.5): ~A" (outp 3))))
(set! *mus-array-print-length* 8)
@@ -18516,13 +18331,13 @@ EDITS: 2
(if (not (= (mus-channels gen2) 4)) (snd-display ";mus-channels move-sound (4): ~A" (mus-channels gen2)))
(mus-reset gen1) ; a no-op
- (let ((v (make-float-vector 10 0.0)))
+ (let ((v (make-float-vector 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (+ (move-sound gen1 i 0.5)
(gen2 i 0.25)
(move-sound gen3 i 0.125))))
- (if (not (vequal v (make-float-vector 10 0.875)))
+ (if (not (mus-arrays-equal? v (make-float-vector 10 0.875)))
(snd-display ";move-sound output: ~A" v)))
(let ((var (catch #t (lambda () (make-move-sound (list 0 1000 1 0 (make-oscil 32) (make-env '(0 0 1 1) :length 1001)
@@ -18578,7 +18393,7 @@ EDITS: 2
(if (fneq (float-vector-peak vo) 0.484)
(snd-display ";move-sound float-vector output: ~A" (float-vector-peak vo))))
- (let* ((vo (make-float-vector (list 1 1000) 0.0))
+ (let* ((vo (make-float-vector '(1 1000)))
(gen1 (make-move-sound (list 0 1000 1 0
(make-delay 32)
(make-env '(0 0 1 1) :length 1001)
@@ -18622,7 +18437,7 @@ EDITS: 2
(if (fneq (float-vector-peak vo) 0.484)
(snd-display ";move-sound opt float-vector output: ~A" (float-vector-peak vo))))
- (let* ((vo (make-float-vector (list 1 1000) 0.0))
+ (let* ((vo (make-float-vector '(1 1000)))
(gen1 (make-move-sound (list 0 1000 1 0
(make-delay 32)
(make-env '(0 0 1 1) :length 1001)
@@ -18705,9 +18520,6 @@ EDITS: 2
(fill-float-vector v1 (if (granulate? gen1) (granulate gen1) -1.0))
(let ((worst (abs (- (float-vector-peak v0) (float-vector-peak v1)))))
(if (> worst .01) (snd-display ";run granulate: ~A" worst))))
- (let ((genx gen1))
- (if (not (equal? genx gen1))
- (snd-display ";granulate equal? ~A ~A ~A" genx gen1 (equal? genx gen1))))
(if (equal? gen gen1) (snd-display ";granulate equal? ~A ~A" gen gen1)))
(if (= (float-vector-peak v0) 0.0) (snd-display ";granulate output peak: ~F?" (float-vector-peak v0))))
(if (not (granulate? gen)) (snd-display ";~A not granulate?" gen))
@@ -18834,11 +18646,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.06) (snd-display ";gran 0 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060 0.060 0.060 0.053
0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 0 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.000 0.000 0.000 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060
0.060 0.060 0.053 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000)))
(snd-display ";gran 0 data 85: ~A" (channel->float-vector 85 30)))
@@ -18848,11 +18660,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.06) (snd-display ";gran 1 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060 0.060 0.060 0.060 0.053
0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 1 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 40 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 40 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.007 0.013 0.020 0.027 0.033 0.040 0.047 0.053 0.060 0.060 0.060
0.060 0.060 0.060 0.053 0.047 0.040 0.033 0.027 0.020 0.013 0.007 0.000 0.000 0.000)))
(snd-display ";gran 1 data 40: ~A" (channel->float-vector 85 30)))
@@ -18862,11 +18674,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.06) (snd-display ";gran 2 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.030 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.030 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 2 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 40 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 40 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.030 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.030 0.000 0.000 0.000)))
(snd-display ";gran 2 data 40: ~A" (channel->float-vector 40 30)))
@@ -18876,11 +18688,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.06) (snd-display ";gran 3 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060 0.055 0.049 0.044
0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 3 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.000 0.000 0.000 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060
0.055 0.049 0.044 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.000 0.000 0.000 0.000)))
(snd-display ";gran 3 data 85: ~A" (channel->float-vector 85 30)))
@@ -18890,11 +18702,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.06) (snd-display ";gran 4 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060 0.055 0.049 0.044
0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022 0.027 0.033 0.038)))
(snd-display ";gran 4 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022 0.027 0.033 0.038 0.044 0.049 0.055 0.060 0.060
0.055 0.049 0.044 0.038 0.033 0.027 0.022 0.016 0.011 0.005 0.005 0.011 0.016 0.022)))
(snd-display ";gran 4 data 85: ~A" (channel->float-vector 85 30)))
@@ -18904,11 +18716,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";gran 5 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.020 0.040 0.060 0.080 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
0.100 0.100 0.100 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080 0.100 0.100 0.100)))
(snd-display ";gran 5 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.080 0.060 0.040 0.020 0.020 0.040 0.060 0.080)))
(snd-display ";gran 5 data 85: ~A" (channel->float-vector 85 30)))
@@ -18918,11 +18730,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.105) (snd-display ";gran 6 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.005 0.009 0.014 0.018 0.023 0.027 0.032 0.036 0.041 0.045 0.050 0.055 0.059 0.064 0.068
0.073 0.077 0.082 0.086 0.091 0.095 0.100 0.105 0.105 0.105 0.105 0.105 0.105 0.105)))
(snd-display ";gran 6 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105
0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105 0.105)))
(snd-display ";gran 6 data 85: ~A" (channel->float-vector 85 30)))
@@ -18932,11 +18744,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.264) (snd-display ";gran 7 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
(snd-display ";gran 7 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 85 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 85 30)
(float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
(snd-display ";gran 7 data 85: ~A" (channel->float-vector 85 30)))
@@ -18946,11 +18758,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";gran 8 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 8 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 220 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 220 30)
(float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 8 data 220: ~A" (channel->float-vector 220 30)))
@@ -18960,11 +18772,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";gran 9 max: ~A" mx))) ; same as 8 because expansion hits the input counter
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 9 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 220 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 220 30)
(float-vector 0.000 0.009 0.018 0.027 0.036 0.045 0.055 0.064 0.073 0.082 0.091 0.100 0.100 0.091 0.082 0.073
0.064 0.055 0.045 0.036 0.027 0.018 0.009 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 9 data 220: ~A" (channel->float-vector 220 30)))
@@ -18978,11 +18790,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx (* 2 0.264)) (snd-display ";gran 10 max: ~A" mx)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 0 30) 0.5)
+ (if (not (mus-arrays-equal? (float-vector-scale! (channel->float-vector 0 30) 0.5)
(float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
(snd-display ";gran 10 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 85 30) 0.5)
+ (if (not (mus-arrays-equal? (float-vector-scale! (channel->float-vector 85 30) 0.5)
(float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
(snd-display ";gran 10 data 85: ~A" (channel->float-vector 85 30)))
@@ -18996,20 +18808,19 @@ EDITS: 2
(f2 (lambda (g)
(if forward ; no change to data
(set! forward #f)
- (let* ((len (mus-length g))
- (grain (make-shared-vector (mus-data g) (list len))))
+ (let ((grain (make-shared-vector (mus-data g) (list (mus-length g)))))
(set! forward #t)
- (set! grain (reverse! grain)))) ; should get ramps going up then down across overall rising ramp
+ (reverse! grain))) ; should get ramps going up then down across overall rising ramp
(mus-length g))))
(let ((gen (make-granulate :jitter 0.0 :hop .005 :length .002 :ramp 0.0 :scaler 1.0 :input f1 :edit f2)))
(map-channel (lambda (y) (granulate gen))))))
(let ((mx (maxamp)))
(if (> mx 0.6) (snd-display ";gran 11 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
-0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
(snd-display ";gran 11 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 100 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 100 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.345 -0.346 -0.347 -0.348 -0.349
-0.350 -0.351 -0.352 -0.353 -0.354 -0.355 -0.356 -0.357 -0.358 -0.359 -0.360 -0.361 -0.362 -0.363 -0.364)))
(snd-display ";gran 11 data 100: ~A" (channel->float-vector 100 30)))
@@ -19022,11 +18833,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen)))))
(let ((mx (maxamp)))
(if (> mx 0.6) (snd-display ";gran 12 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
-0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
(snd-display ";gran 12 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 100 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 100 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.389 -0.388 -0.387 -0.386 -0.385
-0.384 -0.383 -0.382 -0.381 -0.380 -0.379 -0.378 -0.377 -0.376 -0.375 -0.374 -0.373 -0.372 -0.371 -0.370)))
(snd-display ";gran 12 data 100: ~A" (channel->float-vector 100 30)))
@@ -19040,11 +18851,11 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (> mx .6) (snd-display ";gran 13 max: ~A" mx)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 0 30) 0.5)
+ (if (not (mus-arrays-equal? (float-vector-scale! (channel->float-vector 0 30) 0.5)
(float-vector 0.000 0.002 0.004 0.005 0.007 0.009 0.011 0.013 0.015 0.016 0.018 0.020 0.022 0.024 0.025 0.027
0.029 0.031 0.033 0.035 0.036 0.038 0.040 0.044 0.047 0.051 0.055 0.058 0.062 0.065)))
(snd-display ";gran 13 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (float-vector-scale! (channel->float-vector 85 30) 0.5)
+ (if (not (mus-arrays-equal? (float-vector-scale! (channel->float-vector 85 30) 0.5)
(float-vector 0.244 0.244 0.244 0.244 0.245 0.247 0.249 0.251 0.253 0.255 0.256 0.258 0.260 0.262 0.264 0.264
0.262 0.260 0.258 0.256 0.255 0.253 0.251 0.249 0.247 0.245 0.245 0.247 0.249 0.251)))
(snd-display ";gran 13 data 85: ~A" (channel->float-vector 85 30)))
@@ -19058,19 +18869,18 @@ EDITS: 2
:edit (lambda (g)
(if forward
(set! forward #f)
- (let* ((len (mus-length g))
- (grain (make-shared-vector (mus-data g) (list len))))
+ (let ((grain (make-shared-vector (mus-data g) (list (mus-length g)))))
(set! forward #t)
(reverse! grain)))
(mus-length g)))))
(map-channel (lambda (y) (granulate gen)))))
(let ((mx (maxamp)))
(if (> mx 0.6) (snd-display ";gran 14 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector -0.499 -0.498 -0.497 -0.496 -0.495 -0.494 -0.493 -0.492 -0.491 -0.490 -0.489 -0.488 -0.487 -0.486
-0.485 -0.484 -0.483 -0.482 -0.481 -0.480 -0.479 -0.478 -0.477 -0.476 -0.475 -0.474 -0.473 -0.472 -0.471 -0.470)))
(snd-display ";gran 14 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 100 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 100 30)
(float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 -0.345 -0.346 -0.347 -0.348 -0.349
-0.350 -0.351 -0.352 -0.353 -0.354 -0.355 -0.356 -0.357 -0.358 -0.359 -0.360 -0.361 -0.362 -0.363 -0.364)))
(snd-display ";gran 14 data 100: ~A" (channel->float-vector 100 30)))
@@ -19088,15 +18898,15 @@ EDITS: 2
(if (fneq mx 0.06) (snd-display ";granf 0 max: ~A" mx)))
(if (> (abs (- (mus-ramp gen) (* .5 (mus-length gen)))) 1)
(snd-display ";granf 0 ramp: ~A ~A" (mus-ramp gen) (mus-length gen))))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 0 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.000 0.012 0.024 0.036 0.048 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.048 0.036 0.024 0.012 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 0 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 880 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 880 30)
(float-vector 0.000 0.006 0.012 0.018 0.024 0.030 0.036 0.042 0.048 0.054 0.060 0.060 0.060 0.060
0.054 0.048 0.042 0.036 0.030 0.024 0.018 0.012 0.006 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 0 data 880: ~A" (channel->float-vector 880 30)))
@@ -19114,11 +18924,11 @@ EDITS: 2
(if (fneq mx 0.06) (snd-display ";granf 1 max: ~A" mx)))
(if (> (abs (- (mus-hop gen) (* .001 *clm-srate*))) 1)
(snd-display ";granf 1 hop: ~A ~A, ~A ~A" (mus-hop gen) (abs (- (mus-hop gen) (* .001 (srate)))) (srate) *clm-srate*)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 1 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 900 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 900 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000
0.000 0.000 0.000 0.000 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
(snd-display ";granf 1 data 900: ~A" (channel->float-vector 900 30)))
@@ -19136,11 +18946,11 @@ EDITS: 2
(if (fneq mx 0.06) (snd-display ";granf 2 max: ~A" mx)))
(if (> (abs (- (mus-hop gen) (* .001 *clm-srate*))) 1)
(snd-display ";granf 2 hop: ~A" (mus-hop gen))))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 2 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 900 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 900 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
(snd-display ";granf 2 data 900: ~A" (channel->float-vector 900 30)))
@@ -19150,7 +18960,7 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";granf 3 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";gran 3 data: ~A" (channel->float-vector 0 30)))
@@ -19165,15 +18975,15 @@ EDITS: 2
result))))
(let ((mx (maxamp)))
(if (fneq mx 0.1) (snd-display ";granf 4 max: ~A" mx)))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100
0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.100 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 4 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056
0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.056 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 4 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 900 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 900 30)
(float-vector 0.012 0.012 0.012 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 4 data 900: ~A" (channel->float-vector 900 30)))
@@ -19191,15 +19001,15 @@ EDITS: 2
(if (fneq mx 0.06) (snd-display ";granf 5 max: ~A" mx)))
(if (> (abs (- (mus-length gen) (* 5 base-len))) 10)
(snd-display ";granf 5 length: ~A ~A" (mus-length gen) (* 5 base-len)))))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 5 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 440 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 440 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 5 data 440: ~A" (channel->float-vector 440 30)))
- (if (not (vequal (channel->float-vector 800 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 800 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
(snd-display ";granf 5 data 800: ~A" (channel->float-vector 800 30)))
@@ -19217,11 +19027,11 @@ EDITS: 2
(if (fneq mx 0.06) (snd-display ";granf 6 max: ~A" mx)))
(if (> (abs (- (mus-length gen) (* .2 base-len))) 4)
(snd-display ";granf 6 length: ~A ~A" (mus-length gen) (* .2 base-len)))))
- (if (not (vequal (channel->float-vector 0 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060
0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060)))
(snd-display ";granf 6 data: ~A" (channel->float-vector 0 30)))
- (if (not (vequal (channel->float-vector 820 30)
+ (if (not (mus-arrays-equal? (channel->float-vector 820 30)
(float-vector 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.060 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";granf 6 data 820: ~A" (channel->float-vector 820 30)))
@@ -19242,7 +19052,7 @@ EDITS: 2
(let ((gen (make-granulate :jitter 0.0 :hop .01 :length .001 :ramp .5 :scaler 1.0 :expansion 0.5 :input (lambda (dir) .1))))
(map-channel (lambda (y) (granulate gen)))
(let ((vals (max-list)))
- (if (not (equal? vals (list 11 231 451 671 891)))
+ (if (not (equal? vals '(11 231 451 671 891)))
(snd-display ";grn jitter 0 max: ~A" vals)))
(undo))
@@ -19251,7 +19061,7 @@ EDITS: 2
(map-channel (lambda (y) (granulate gen)))
;; (11 232 490 736 982) or whatever
(let ((vals (max-list)))
- (if (equal? vals (list 11 231 451 671 891))
+ (if (equal? vals '(11 231 451 671 891))
(snd-display ";grn jitter 0.3 max: ~A" vals))
(set! oldvals vals))
(undo))
@@ -19340,11 +19150,11 @@ EDITS: 2
(if (fneq (maxamp) .462) (snd-display ";granulate ramped 4: ~A" (maxamp)))
(let ((vals (count-matches (lambda (y) (> (abs y) 0.0)))))
(if (> (abs (- vals 1104)) 10) (snd-display ";granulate ramped 4 not 0.0: ~A" vals)))
- (if (not (and (vequal (channel->float-vector 2203 10)
+ (if (not (and (mus-arrays-equal? (channel->float-vector 2203 10)
(float-vector 0.000 0.000 0.110 0.110 0.110 0.111 0.111 0.111 0.111 0.111))
- (vequal (channel->float-vector 4523 10)
+ (mus-arrays-equal? (channel->float-vector 4523 10)
(float-vector 0.232 0.232 0.232 0.232 0.232 0.232 0.232 0.232 0.233 0.233))
- (vequal (channel->float-vector 8928 10)
+ (mus-arrays-equal? (channel->float-vector 8928 10)
(float-vector 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452 0.452))))
(snd-display ";granulate ramped 4 data off: ~A ~A ~A"
(channel->float-vector 2203 10) (channel->float-vector 4523 10) (channel->float-vector 8928 10)))
@@ -19383,9 +19193,9 @@ EDITS: 2
:jitter 0.0))
(clm-channel gen))
(if (fneq (maxamp) .495) (snd-display ";granulate ramped 6: ~A" (maxamp)))
- (if (not (and (vequal (channel->float-vector 2000 10)
+ (if (not (and (mus-arrays-equal? (channel->float-vector 2000 10)
(float-vector 0.018 0.019 0.020 0.021 0.022 0.023 0.024 0.025 0.026 0.027))
- (vequal (channel->float-vector 8000 10)
+ (mus-arrays-equal? (channel->float-vector 8000 10)
(float-vector 0.294 0.298 0.301 0.305 0.309 0.313 0.316 0.320 0.324 0.328))))
(snd-display ";granulate ramped 6 data: ~A ~A"
(channel->float-vector 2000 10) (channel->float-vector 8000 10)))
@@ -19401,9 +19211,9 @@ EDITS: 2
:jitter 0.0))
(clm-channel gen))
(if (fneq (maxamp) .505) (snd-display ";granulate ramped 7: ~A" (maxamp)))
- (if (not (and (vequal (channel->float-vector 2000 10)
+ (if (not (and (mus-arrays-equal? (channel->float-vector 2000 10)
(float-vector 0.037 0.039 0.040 0.042 0.044 0.046 0.048 0.050 0.052 0.054))
- (vequal (channel->float-vector 8000 10)
+ (mus-arrays-equal? (channel->float-vector 8000 10)
(float-vector 0.404 0.404 0.404 0.404 0.404 0.405 0.405 0.405 0.405 0.405))))
(snd-display ";granulate ramped 7 data: ~A ~A"
(channel->float-vector 2000 10) (channel->float-vector 8000 10)))
@@ -19489,15 +19299,13 @@ EDITS: 2
"convolve"
"convolve size: 64")
(if (not (convolve? gen)) (snd-display ";~A not convolve?" gen))
- (let ((genx gen1))
- (if (not (equal? genx gen1)) (snd-display ";convolve equal?: ~A ~A ~A" genx gen1 (equal? genx gen1))))
(if (equal? gen gen1) (snd-display ";convolve equal? ~A ~A" gen gen1))
(if (not (= (mus-length gen) 64)) (snd-display ";convolve fft len: ~D?" (mus-length gen)))
(do ((i 0 (+ i 1)))
((= i 128))
(set! (v2 i) (convolve gen)))
(fill-float-vector v21 (if (convolve? gen1) (convolve gen1) -1.0))
- (if (not (vequal v2 v21)) (snd-display ";run gran: ~A ~A" v2 v21))
+ (if (not (mus-arrays-equal? v2 v21)) (snd-display ";run gran: ~A ~A" v2 v21))
(if (or (fneq (v2 0) 0.0)
(fneq (v2 1) 1.0)
(fneq (v2 4) 0.25)
@@ -19520,13 +19328,13 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 16))
(set! (res i) (convolve g)))
- (if (not (vequal res (float-vector 0.0 1.0 0.5 0.1 1.2 0.8 0.5 0.7 1.3 0.4 0.5 1.0 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? res (float-vector 0.0 1.0 0.5 0.1 1.2 0.8 0.5 0.7 1.3 0.4 0.5 1.0 0.0 0.0 0.0 0.0)))
(snd-display ";convolve: ~A~%" res))))
(let ((ind (new-sound "fmv.snd")))
(set! (sample 1) .1)
(save-sound ind)
- (if (not (equal? (edits ind 0) (list 0 0)))
+ (if (not (equal? (edits ind 0) '(0 0)))
(snd-display ";weird: edits not cleared after save-sound?: ~A" (edits ind 0)))
(close-sound ind)
(set! ind (open-sound "fmv.snd"))
@@ -19539,7 +19347,7 @@ EDITS: 2
((= i 6))
(set! (sample i) (* i .1))
(save-sound ind)
- (if (not (equal? (edits ind 0) (list 0 0)))
+ (if (not (equal? (edits ind 0) '(0 0)))
(snd-display ";weird: edits not cleared after save-sound ~A?: ~A" i (edits ind 0)))
(close-sound ind)
(set! ind (open-sound "fmv.snd"))
@@ -19652,12 +19460,10 @@ EDITS: 2
(if (or (fneq (sample 50) .5) (fneq (sample 30) 0.20608) (fneq (sample 90) 0.9755))
(snd-display ";smooth: ~A ~A ~A?" (sample 50) (sample 30) (sample 90)))
(undo)
- (let ((old-wid *sinc-width*))
- (set! *sinc-width* 40)
+ (let-temporarily ((*sinc-width* 40))
(set! (sample 100) 0.5)
(if (fneq (sample 100) 0.5) (snd-display ";set-sample 100: ~A?" (sample 100)))
- (src-sound .1)
- (set! *sinc-width* old-wid))
+ (src-sound .1) )
(if (or (fneq (sample 1000) 0.5) (fneq (sample 1024) 0.0625) (fneq (sample 1010) 0.0))
(snd-display ";src-sound: ~A ~A ~A?" (sample 1000) (sample 1024) (sample 1010)))
(revert-sound)
@@ -19843,7 +19649,7 @@ EDITS: 2
(mus-file-mix-1 k (make-mix-input "oboe.snd" k) 0 len 0 (float-vector 1.0) outv))
(let ((ind-oboe (open-sound "oboe.snd"))
(ind-mix (open-sound "fmv.snd")))
- (if (not (vequal (channel->float-vector 1000 10 ind-oboe)
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 10 ind-oboe)
(float-vector-scale! (channel->float-vector 1000 10 ind-mix) (/ 1.0 2.5))))
(snd-display ";~D mus-file-mix 1 chan: ~A ~A" k
(channel->float-vector 1000 10 ind-oboe)
@@ -19868,7 +19674,7 @@ EDITS: 2
(let ((ind-mix (open-sound "fmv.snd")))
(if (not (= (channels ind-mix) 2))
(snd-display ";~D fmv re-read chans? ~A ~A" k (mus-sound-chans "fmv.snd") (channels ind-mix)))
- (if (not (vequal (channel->float-vector 1000 10 ind-mix 0)
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 10 ind-mix 0)
(float-vector 0.003 0.010 0.012 0.011 0.008 0.004 0.002 0.002 0.007 0.017)))
(snd-display ";~D mus-file-mix 2 chan (2.snd written: ~A): ~A ~A" k
(strftime "%d-%b %H:%M %Z" (localtime (mus-sound-write-date "2.snd")))
@@ -20116,9 +19922,7 @@ EDITS: 2
(if (not (= (mus-hop genx) 128)) (snd-display ";phase vocoder hop: ~A" (mus-hop genx)))
(set! (mus-hop genx) 64)
(if (not (= (mus-hop genx) 64)) (snd-display ";set phase vocoder hop: ~A" (mus-hop genx)))
- (if (not (= (mus-length genx) 512)) (snd-display ";phase vocoder length: ~A" (mus-length genx)))
- (let ((genxx genx))
- (if (not (equal? genx genxx)) (snd-display ";phase-vocoder equal: ~A ~A" genxx genx))))
+ (if (not (= (mus-length genx) 512)) (snd-display ";phase vocoder length: ~A" (mus-length genx))))
(close-sound ind))
(let ((old-fudge *mus-float-equal-fudge-factor*) ; some phase-vocoder tests
@@ -20202,58 +20006,56 @@ EDITS: 2
(let ()
(define (pvoc-d beg dur amp size)
- (let ((N2 (floor (/ size 2))))
- (let ((start (seconds->samples beg))
- (end (seconds->samples (+ beg dur)))
- (two-pi (* 2 pi))
- (amps #f) (paincrs #f) (ppincrs #f) (phases #f) (freqs #f))
-
- (define ifunc
- (let ((osc (make-oscil 1000.0)))
- (lambda (dir)
- (oscil osc))))
-
- (define efunc
- (let ((lastphases (make-float-vector N2)))
- (lambda (c)
- (let* ((D (floor (/ size 4))) ; overlap = 4
- (pscl (/ 1.0 D))
- (kscl (/ two-pi size)))
- (do ((k 0 (+ k 1))
- (ks 0.0 (+ ks kscl)))
- ((= k N2))
- (let* ((freq (freqs k))
- (diff (- freq (lastphases k))))
- (set! (lastphases k) freq)
- (if (> diff pi) (set! diff (- diff two-pi)))
- (if (< diff (- pi)) (set! diff (+ diff two-pi)))
- (set! (freqs k) (+ (* diff pscl) ks))))
- #f))))
+ (let ((N2 (floor (/ size 2)))
+ (start (seconds->samples beg))
+ (end (seconds->samples (+ beg dur)))
+ (two-pi (* 2 pi))
+ (amps #f) (paincrs #f) (ppincrs #f) (phases #f) (freqs #f))
+
+ (define ifunc
+ (let ((osc (make-oscil 1000.0)))
+ (lambda (dir)
+ (oscil osc))))
+
+ (define efunc
+ (let ((lastphases (make-float-vector N2)))
+ (lambda (c)
+ (do ((pscl (/ 1.0 (floor (/ size 4)))) ; overlap = 4
+ (kscl (/ two-pi size))
+ (k 0 (+ k 1))
+ (ks 0.0 (+ ks kscl)))
+ ((= k N2) #f)
+ (let* ((freq (freqs k))
+ (diff (- freq (lastphases k))))
+ (set! (lastphases k) freq)
+ (if (> diff pi) (set! diff (- diff two-pi)))
+ (if (< diff (- pi)) (set! diff (+ diff two-pi)))
+ (set! (freqs k) (+ (* diff pscl) ks)))))))
+
+ (define (sfunc c)
+ (float-vector-add! amps paincrs)
+ (float-vector-add! ppincrs freqs)
+ (float-vector-add! phases ppincrs)
+ (let ((sum 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i N2))
+ (if (> (amps i) .75)
+ (set! sum (+ sum (* (amps i) (if (> (modulo (phases i) two-pi) pi) 1.0 -1.0))))))
+ sum))
+
+ (let ((sr (make-phase-vocoder :fft-size size :interp (/ size 4) :overlap 4
+ :edit efunc
+ :synthesize sfunc
+ :input ifunc)))
+ (set! amps (phase-vocoder-amps sr))
+ (set! paincrs (phase-vocoder-amp-increments sr))
+ (set! ppincrs (phase-vocoder-phase-increments sr))
+ (set! phases (phase-vocoder-phases sr))
+ (set! freqs (phase-vocoder-freqs sr))
- (define (sfunc c)
- (float-vector-add! amps paincrs)
- (float-vector-add! ppincrs freqs)
- (float-vector-add! phases ppincrs)
- (let ((sum 0.0))
- (do ((i 0 (+ i 1)))
- ((= i N2))
- (if (> (amps i) .75)
- (set! sum (+ sum (* (amps i) (if (> (modulo (phases i) two-pi) pi) 1.0 -1.0))))))
- sum))
-
- (let ((sr (make-phase-vocoder :fft-size size :interp (/ size 4) :overlap 4
- :edit efunc
- :synthesize sfunc
- :input ifunc)))
- (set! amps (phase-vocoder-amps sr))
- (set! paincrs (phase-vocoder-amp-increments sr))
- (set! ppincrs (phase-vocoder-phase-increments sr))
- (set! phases (phase-vocoder-phases sr))
- (set! freqs (phase-vocoder-freqs sr))
-
- (do ((i start (+ i 1)))
- ((= i end))
- (outa i (* amp (phase-vocoder sr))))))))
+ (do ((i start (+ i 1)))
+ ((= i end))
+ (outa i (* amp (phase-vocoder sr)))))))
(let ((v (make-float-vector 200)))
(with-sound (v :srate 44100) (pvoc-d 0 .0025 .2 128))
@@ -20279,7 +20081,7 @@ EDITS: 2
(do ((i 1 (+ i 1)))
((= i 20))
(set! (vals i) (moog-filter gen 0.0)))
- (if (not (vequal vals (float-vector 0.0 0.0 0.0025 0.0062 0.0120 0.0198 0.0292 0.0398 0.0510 0.0625
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 0.0 0.0025 0.0062 0.0120 0.0198 0.0292 0.0398 0.0510 0.0625
0.0739 0.0847 0.0946 0.1036 0.1113 0.1177 0.1228 0.1266 0.1290 0.1301)))
(snd-display ";moog output: ~A" vals))))
(close-sound ind))
@@ -20297,7 +20099,7 @@ EDITS: 2
((= i 10))
(set! (v0 i) (ssb-am gen)))
(fill-float-vector v1 (if (ssb-am? gen1) (ssb-am gen1) -1.0))
- (if (not (vequal v0 v1)) (snd-display ";map ssb-am: ~A ~A" v0 v1)))
+ (if (not (mus-arrays-equal? v0 v1)) (snd-display ";map ssb-am: ~A ~A" v0 v1)))
(if (not (ssb-am? gen)) (snd-display ";~A not ssb-am?" gen))
(if (fneq (mus-phase gen) 1.253787) (snd-display ";ssb-am phase: ~F?" (mus-phase gen)))
(if (fneq (mus-frequency gen) 440.0) (snd-display ";ssb-am frequency: ~F?" (mus-frequency gen)))
@@ -20569,11 +20371,11 @@ EDITS: 2
(lambda (arg2)
(catch #t (lambda () (runp gen arg1 arg2)) (lambda args (car args))))
(list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
- (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
+ (lambda () #t) (curlet) (make-float-vector '(2 3)) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
() 3 4 2 8 16 32 64 #() '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
)))
(list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
- (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
+ (lambda () #t) (curlet) (make-float-vector '(2 3)) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
() 3 4 2 8 16 32 64 #() '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
))
@@ -20591,7 +20393,7 @@ EDITS: 2
(set! (func gen) arg1))
(lambda args #f)))
(list 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) #(0 1) 3/4 'mus-error 0+i
- (lambda () #t) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
+ (lambda () #t) (make-float-vector '(2 3)) :order 0 1 -1 #f #t #\c 0.0 1.0 -1.0
() 3 4 64 -64 #() '(1 . 2) (expt 2.0 21.5) (expt 2.0 -18.0)
(lambda (a) a)))
(if (not (equal? (func gen) default-value))
@@ -20624,10 +20426,10 @@ EDITS: 2
(list make-oscil make-asymmetric-fm
make-triangle-wave make-square-wave make-pulse-train make-sawtooth-wave
make-rand make-rand-interp)
- (list 'oscil 'asymmetric-fm
- 'triangle-wave 'square-wave 'pusle-train 'sawtooth-wave
- 'rand 'rand-interp)))
- (list 100 1))
+ '(oscil asymmetric-fm
+ triangle-wave square-wave pusle-train sawtooth-wave
+ rand rand-interp)))
+ '(100 1))
(set! *clm-srate* old-clm-srate))
(let ((random-args (list
@@ -20677,50 +20479,50 @@ EDITS: 2
random-args))
random-args))))
- (let* ((gen (make-moving-max 4))
- (ov (make-float-vector 10))
- (iv (float-vector .1 .05 -.2 .15 -1.5 0.1 0.01 0.001 0.0 0.0))
- (tv (float-vector .1 .1 .2 .2 1.5 1.5 1.5 1.5 0.1 0.01)))
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (set! (ov i) (moving-max gen (iv i))))
- (if (not (vequal tv ov))
- (snd-display ";moving-max: ~A ~A" ov tv)))
+ (do ((ov (make-float-vector 10))
+ (tv (float-vector .1 .1 .2 .2 1.5 1.5 1.5 1.5 0.1 0.01))
+ (gen (make-moving-max 4))
+ (iv (float-vector .1 .05 -.2 .15 -1.5 0.1 0.01 0.001 0.0 0.0))
+ (i 0 (+ i 1)))
+ ((= i 10)
+ (if (not (mus-arrays-equal? tv ov))
+ (snd-display ";moving-max: ~A ~A" ov tv)))
+ (set! (ov i) (moving-max gen (iv i))))
(let ((g1 (make-moving-max 10)))
(do ((i 0 (+ i 1)))
((= i 1000))
- (let* ((val (moving-max g1 (random 1.0)))
- (pk (float-vector-peak (mus-data g1))))
+ (let ((val (moving-max g1 (random 1.0)))
+ (pk (float-vector-peak (mus-data g1))))
(if (not (= pk val))
(snd-display ";moving-max ~A ~A" pk val)))))
- (let ((odata (make-float-vector 15 0.0))
+ (let ((odata (make-float-vector 15))
(data (float-vector 1.0 0.0 -1.1 1.1001 0.1 -1.1 1.0 1.0 0.5 -0.01 0.02 0.0 0.0 0.0 0.0))
(g (make-moving-max 3)))
(do ((i 0 (+ i 1))) ((= i 15)) (set! (odata i) (moving-max g (data i))))
- (if (not (vequal odata (float-vector 1.000 1.000 1.100 1.100 1.100 1.100 1.100 1.100 1.000 1.000 0.500 0.020 0.020 0.000 0.000)))
+ (if (not (mus-arrays-equal? odata (float-vector 1.000 1.000 1.100 1.100 1.100 1.100 1.100 1.100 1.000 1.000 0.500 0.020 0.020 0.000 0.000)))
(snd-display ";moving max odata: ~A" odata))
(if (= (odata 4) (odata 7))
(snd-display ";moving-max .0001 offset?"))
- (set! odata (make-float-vector 15 0.0))
+ (set! odata (make-float-vector 15))
(set! data (float-vector 0.1 -0.2 0.3 0.4 -0.5 0.6 0.7 0.8 -0.9 1.0 0.0 0.0))
(set! g (make-moving-sum 3))
(do ((i 0 (+ i 1))) ((= i 12)) (set! (odata i) (moving-sum g (data i))))
- (if (not (vequal odata (float-vector 0.100 0.300 0.600 0.900 1.200 1.500 1.800 2.100 2.400 2.700 1.900 1.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? odata (float-vector 0.100 0.300 0.600 0.900 1.200 1.500 1.800 2.100 2.400 2.700 1.900 1.000 0.000 0.000 0.000)))
(snd-display ";moving-sum odata: ~A" odata))
- (set! odata (make-float-vector 15 0.0))
+ (set! odata (make-float-vector 15))
(set! g (make-moving-rms 4))
(do ((i 0 (+ i 1))) ((= i 12)) (set! (odata i) (moving-rms g (data i))))
- (if (not (vequal odata (float-vector 0.050 0.112 0.187 0.274 0.367 0.464 0.561 0.660 0.758 0.857 0.783 0.673 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? odata (float-vector 0.050 0.112 0.187 0.274 0.367 0.464 0.561 0.660 0.758 0.857 0.783 0.673 0.000 0.000 0.000)))
(snd-display ";moving-rms odata: ~A" odata))
- (set! odata (make-float-vector 15 0.0))
+ (set! odata (make-float-vector 15))
(set! g (make-moving-length 4))
(do ((i 0 (+ i 1))) ((= i 12)) (set! (odata i) (moving-length g (data i))))
- (if (not (vequal odata (float-vector 0.100 0.224 0.374 0.548 0.735 0.927 1.122 1.319 1.517 1.715 1.565 1.345 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? odata (float-vector 0.100 0.224 0.374 0.548 0.735 0.927 1.122 1.319 1.517 1.715 1.565 1.345 0.000 0.000 0.000)))
(snd-display ";moving-length odata: ~A" odata))
(let ((ind (new-sound "test.snd" :size 20)))
@@ -20732,7 +20534,7 @@ EDITS: 2
(undo)
(map-channel (lambda (y) (fir-filter gen2 y)))
(let ((data2 (channel->float-vector)))
- (if (not (vequal data1 data2))
+ (if (not (mus-arrays-equal? data1 data2))
(snd-display ";weighted-moving-average and fir:~%; ~A~%: ~A" data1 data2)))
(undo))
(close-sound ind))
@@ -20783,7 +20585,7 @@ EDITS: 2
(if (fneq (odata k) (sqrt (/ sum 4))) (snd-display ";moving rms ran: ~A ~A" (odata k) (sqrt (/ sum 4)))))))
(let ((ind (open-sound "oboe.snd")))
- (harmonicizer 550.0 (list 1 .5 2 .3 3 .2) 10)
+ (harmonicizer 550.0 '(1 .5 2 .3 3 .2) 10)
(close-sound ind))
(let ((arglist ()))
@@ -20801,9 +20603,9 @@ EDITS: 2
(list make-wave-train make-polyshape make-delay make-moving-average make-moving-max make-moving-norm make-comb make-filtered-comb make-notch
make-rand make-rand-interp make-table-lookup make-env
make-readin make-locsig make-granulate make-convolve make-phase-vocoder)
- (list 'make-wave-train 'make-polyshape 'make-delay 'make-moving-average 'make-moving-max 'make-moving-norm 'make-comb 'make-filtered-comb 'make-notch
- 'make-rand 'make-rand-interp 'make-table-lookup 'make-env
- 'make-readin 'make-locsig 'make-granulate 'make-convolve 'make-phase-vocoder)))
+ '(make-wave-train make-polyshape make-delay make-moving-average make-moving-max make-moving-norm make-comb make-filtered-comb make-notch
+ make-rand make-rand-interp make-table-lookup make-env
+ make-readin make-locsig make-granulate make-convolve make-phase-vocoder)))
(let ((v1 (make-float-vector 10 .1)))
@@ -20902,7 +20704,7 @@ EDITS: 2
(if (or (fneq val val1)
(fneq val1 val2))
(snd-display ";tanh(~A): ~A ~A ~A" x val val1 val2))))
- (list 1.0 0.1 0.1 0.333)))
+ '(1.0 0.1 0.1 0.333)))
(if all-args
(let ((maxerr 0.0)
@@ -20937,7 +20739,7 @@ EDITS: 2
(snd-display ";outa (float-vector) -1 -> ~A" tag)))
(let ((tag (catch #t
- (lambda () (with-sound ((make-float-vector (list 1 10) 0.0)) (outa -1 .1)))
+ (lambda () (with-sound ((make-float-vector '(1 10))) (outa -1 .1)))
(lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
(snd-display ";outa (vector 2) -1 -> ~A" tag)))
@@ -20957,7 +20759,7 @@ EDITS: 2
(outa -1 .1))
(lambda args 'error)))))
(if (> (float-vector-peak v) 0.0) (snd-display ";outa to float-vector at -1: ~A" v)))
- (let ((v (with-sound ((make-float-vector (list 1 10) 0.0)) (catch #t (lambda ()
+ (let ((v (with-sound ((make-float-vector '(1 10))) (catch #t (lambda ()
(outa -1 .1))
(lambda args 'error)))))
(if (> (maxamp v) 0.0) (snd-display ";outa to vector1 at -1: ~A" v)))
@@ -21552,20 +21354,18 @@ EDITS: 2
(format () ";one-pole-all-pass (1) ~A: ~A ~A -> ~A~%" i v1 v2 (abs (- v1 v2)))))))
)
- (let ((old-srate *clm-srate*))
- (set! *clm-srate* 44100)
+ (let-temporarily ((*clm-srate* 44100))
(let ((pe (make-pulsed-env '(0 0 1 1 2 0) .0004 2205))
(v (make-float-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (pulsed-env pe)))
- (if (not (vequal v (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
+ (if (not (mus-arrays-equal? v (float-vector 0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000
0.000 0.125 0.250 0.375 0.500 0.625 0.750 0.875 1.000 0.875 0.750 0.625 0.500 0.375 0.250 0.125 0.000 0.000 0.000 0.000)))
- (snd-display ";pulsed-env: ~A" v)))
- (set! *clm-srate* old-srate))
+ (snd-display ";pulsed-env: ~A" v))))
(copy-test (make-oscil 330.0))
(copy-test (make-ncos 440.0 10))
@@ -21923,7 +21723,7 @@ EDITS: 2
(let ((v (float-vector .1 .2 .3)))
(let ((id (mix-float-vector v 0)))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector .1 .2 .3 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? nv (float-vector .1 .2 .3 0 0 0 0 0 0 0)))
(snd-display ";mix v at 0: ~A" nv)))
(let ((eds (edit-tree ind 0)))
(if (not (feql eds '((0 0 0 2 0.0 0.0 0.0 3) (3 0 3 9 0.0 0.0 0.0 2) (10 -2 0 0 0.0 0.0 0.0 0))))
@@ -21936,7 +21736,7 @@ EDITS: 2
(if (not (null? (mix-amp-env id))) (snd-display ";mix v at 0 amp-env: ~A" (mix-amp-env id)))
(if (not (= (mix-position id) 0)) (snd-display ";mix v at 0 beg: ~A" (mix-position id)))
(if (not (= (mix-length id) 3)) (snd-display ";mix v at 0 length: ~A" (mix-length id)))
- (if (not (equal? (mix-name id) "")) (snd-display ";mix v at 0 name: ~A" (mix-name id)))
+ (if (not (string=? (mix-name id) "")) (snd-display ";mix v at 0 name: ~A" (mix-name id)))
(if (not (null? (mix-properties id))) (snd-display ";mix v at 0 properties: ~A" (mix-properties id)))
(if (not (equal? (mix-color id) *mix-color*)) (snd-display ";mix v at 0 color: ~A" (mix-color id)))
(if (not (= (mix-tag-y id) 0)) (snd-display ";mix v at 0 tag-y: ~A" (mix-tag-y id)))
@@ -21945,7 +21745,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-mix-sample sf)))
- (if (not (vequal data (channel->float-vector)))
+ (if (not (mus-arrays-equal? data (channel->float-vector)))
(snd-display ";mix v at 0 read mix samples: ~A" data))
(if (not (sampler-at-end? sf)) (snd-display ";mix v at 0 reader not at end?"))
(free-sampler sf))
@@ -21955,13 +21755,13 @@ EDITS: 2
(mix-float-vector v 8)
(if (not (= (framples ind 0) 11)) (snd-display ";mix v at 8 new len: ~A" (framples ind 0)))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector 0 0 0 0 0 0 0 0 .1 .2 .3)))
+ (if (not (mus-arrays-equal? nv (float-vector 0 0 0 0 0 0 0 0 .1 .2 .3)))
(snd-display ";mix v at 8: ~A" nv)))
(undo)
(mix-float-vector v 3)
(if (not (= (framples ind 0) 10)) (snd-display ";mix v at 3 new len: ~A" (framples ind 0)))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector 0 0 0 .1 .2 .3 0 0 0 0)))
+ (if (not (mus-arrays-equal? nv (float-vector 0 0 0 .1 .2 .3 0 0 0 0)))
(snd-display ";mix v at 3: ~A" nv)))
(undo))
(let ((v (make-float-vector 20 .5)))
@@ -21979,7 +21779,7 @@ EDITS: 2
(if (not (null? (mix-amp-env id))) (snd-display ";mix oboe at 0 amp-env: ~A" (mix-amp-env id)))
(if (not (= (mix-position id) 0)) (snd-display ";mix oboe at 0 beg: ~A" (mix-position id)))
(if (not (= (mix-length id) 50828)) (snd-display ";mix oboe at 0 length: ~A" (mix-length id)))
- (if (not (equal? (mix-name id) "")) (snd-display ";mix oboe at 0 name: ~A" (mix-name id)))
+ (if (not (string=? (mix-name id) "")) (snd-display ";mix oboe at 0 name: ~A" (mix-name id)))
(if (not (null? (mix-properties id))) (snd-display ";mix oboe at 0 properties: ~A" (mix-properties id)))
(if (not (equal? (mix-color id) *mix-color*)) (snd-display ";mix oboe at 0 color: ~A" (mix-color id)))
(if (not (= (mix-tag-y id) 0)) (snd-display ";mix oboe at 0 tag-y: ~A" (mix-tag-y id)))
@@ -21999,14 +21799,14 @@ EDITS: 2
(scale-by 2.0)
(if (not (mix? id)) (snd-display ";scaled (2) mix not active?"))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector-scale! (float-vector .1 .2 .3 0 0 0 0 0 0 0) 2.0)))
+ (if (not (mus-arrays-equal? nv (float-vector-scale! (float-vector .1 .2 .3 0 0 0 0 0 0 0) 2.0)))
(snd-display ";mix v at 0 scale-by 2: ~A" nv)))
(if (fneq (mix-amp id) 2.0) (snd-display ";mix then scale mix amp: ~A" (mix-amp id)))
(undo)
(delete-sample 1)
(if (not (mix? id)) (snd-display ";delete hit mix: ~A" (mix? id)))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector .1 .3 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? nv (float-vector .1 .3 0 0 0 0 0 0 0)))
(snd-display ";mix v at 0 delete .2: ~A" nv)))
(revert-sound ind))
(let ((id (mix-float-vector v 0)))
@@ -22014,7 +21814,7 @@ EDITS: 2
(reverse-sound ind 0)
(if (not (mix? id)) (snd-display ";reversed mix: ~A" (mix? id)))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (reverse! (float-vector .1 .2 .3 0 0 0 0 0 0))))
+ (if (not (mus-arrays-equal? nv (reverse! (float-vector .1 .2 .3 0 0 0 0 0 0))))
(snd-display ";mix v at 0 reversed: ~A" nv)))
(undo)
(if (not (mix? id)) (snd-display ";revert reverse mix: ~A" (mix? id)))
@@ -22026,7 +21826,7 @@ EDITS: 2
(scale-by 3.0)
(if (not (mix? id)) (snd-display ";scaled (3) mix not active?"))
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector-scale! (float-vector-add! (make-float-vector 9 .2) (float-vector .1 .2 .3)) 3.0)))
+ (if (not (mus-arrays-equal? nv (float-vector-scale! (float-vector-add! (make-float-vector 9 .2) (float-vector .1 .2 .3)) 3.0)))
(snd-display ";mix v at 0 scale-by 2 and 3: ~A" nv))))
(revert-sound ind)
(map-channel (lambda (y) 1.0))
@@ -22034,7 +21834,7 @@ EDITS: 2
(let ((v (float-vector .1 .2 .3)))
(mix-float-vector v 3)
(let ((nv (channel->float-vector)))
- (if (not (vequal nv (float-vector 0.000 0.200 0.400 0.700 1.000 1.300 0.800 0.600 0.400 0.200)))
+ (if (not (mus-arrays-equal? nv (float-vector 0.000 0.200 0.400 0.700 1.000 1.300 0.800 0.600 0.400 0.200)))
(snd-display ";mix v at 3 after env: ~A" nv))))
(close-sound ind)))
@@ -22054,25 +21854,25 @@ EDITS: 2
(let ((id1 (mix-float-vector v 22))
(id2 (mix-float-vector v 21)))
(let ((vals (channel->float-vector 18 10)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.300 0.600 0.500 0.300 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.100 0.300 0.600 0.500 0.300 0.000 0.000 0.000)))
(snd-display ";mix 3 vs: ~A" vals))
(if (not (mix? id)) (snd-display ";mix 3vs 1 not active?"))
(if (not (mix? id1)) (snd-display ";mix 3vs 2 not active?"))
(if (not (mix? id2)) (snd-display ";mix 3vs 3 not active?"))
(set! (mix-position id) 10)
(set! vals (channel->float-vector 18 10))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.100 0.300 0.500 0.300 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.000 0.100 0.300 0.500 0.300 0.000 0.000 0.000)))
(snd-display ";mix 3 vs then move first: ~A" vals))
(set! (mix-position id2) 30)
(set! vals (channel->float-vector 18 10))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.000 0.000 0.000)))
(snd-display ";mix 3 vs then move 2: ~A" vals))
(scale-by 2.0)
(if (not (mix? id)) (snd-display ";mix 3vs 1 scl not active?"))
(if (not (mix? id1)) (snd-display ";mix 3vs 2 scl not active?"))
(if (not (mix? id2)) (snd-display ";mix 3vs 3 scl not active?"))
(set! vals (channel->float-vector 18 10))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.200 0.400 0.600 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.000 0.000 0.200 0.400 0.600 0.000 0.000 0.000)))
(snd-display ";mix 3 vs then move 2 scl: ~A" vals))
(delete-sample 15)
(if (not (mix? id)) (snd-display ";mix 3vs 1 scl del not active?"))
@@ -22088,7 +21888,7 @@ EDITS: 2
(id (mix-float-vector (make-float-vector 11 1.0) 2)))
(set! (mix-amp-env id) '(0 0 1 1))
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0 0 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 0 0)))
+ (if (not (mus-arrays-equal? vals (float-vector 0 0 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 0 0)))
(snd-display ";ramp mix amp env: ~A" vals)))
(set! (mix-amp-env id) #f)
(if (pair? (mix-amp-env id)) (snd-display ";set mix-amp-env to null: ~A" (mix-amp-env id)))
@@ -22096,14 +21896,14 @@ EDITS: 2
(if (not (= (framples) 24)) (snd-display ";mix speed lengthens 24: ~A" (framples)))
(set! (mix-speed id) 1.0)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";return to mix original index: ~A" vals)))
(set! (mix-amp-env id) '(0 0 1 1 2 1 3 0))
(set! (mix-speed id) 0.5)
(set! (mix-amp-env id) #f)
(set! (mix-speed id) 1.0)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? vals (float-vector 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";return again to mix original index: ~A" vals)))
(close-sound ind))
@@ -22123,8 +21923,8 @@ EDITS: 2
(md (car (mix "1a.snd" 1000 0 ind 1 #t))))
(if (fneq (maxamp ind 1) .1665) (snd-display ";maxamp after mix into chan 2: ~A" (maxamp ind 1)))
(set! (mix-amp md) 0.0)
- (if (not (and (equal? (edits ind 0) (list 0 0))
- (equal? (edits ind 1) (list 2 0))))
+ (if (not (and (equal? (edits ind 0) '(0 0))
+ (equal? (edits ind 1) '(2 0))))
(snd-display ";mix into chan2 zeroed: ~A ~A" (edits ind 0) (edits ind 1)))
(if (fneq (maxamp ind 1) .066) (snd-display ";maxamp after mix zeroed into chan 2: ~A" (maxamp ind 1)))
(set! (mix-amp md) 0.5)
@@ -22166,28 +21966,28 @@ EDITS: 2
(close-sound indout))
(let ((tag (car (mix "test.snd"))))
(let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(set! (v 2) .5)
(set! (v 5) .25)
- (if (not (vequal samps v))
+ (if (not (mus-arrays-equal? samps v))
(snd-display ";mix 1->1: ~A ~A" samps v)))
(if (not (mix? tag)) (snd-display ";mix 1->1 tag: ~A" tag))
(undo))
(let ((tag (car (mix "test.snd" 5))))
(let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(set! (v 7) .5)
(set! (v 10) .25)
- (if (not (vequal samps v))
+ (if (not (mus-arrays-equal? samps v))
(snd-display ";mix 1->1 at 5: ~A ~A" samps v)))
(if (not (mix? tag)) (snd-display ";mix 1->1 at 5 tag: ~A" tag))
(undo))
(let ((tag (mix "test.snd" 0 0 ind 0 #f)))
(let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(set! (v 2) .5)
(set! (v 5) .25)
- (if (not (vequal samps v))
+ (if (not (mus-arrays-equal? samps v))
(snd-display ";mix 1->1 at 0 #f: ~A ~A" samps v)))
(if (mix? tag) (snd-display ";mix 1->1 at 5 #f tag: ~A" tag))
(undo))
@@ -22202,19 +22002,19 @@ EDITS: 2
(close-sound indout))
(let ((tag (car (mix "test.snd" 0 1))))
(let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(set! (v 2) .95)
(set! (v 5) .125)
- (if (not (vequal samps v))
+ (if (not (mus-arrays-equal? samps v))
(snd-display ";mix 2->1: ~A ~A" samps v)))
(if (not (mix? tag)) (snd-display ";mix 2->1 tag: ~A" tag))
(undo))
(let ((tag (car (mix "test.snd" 5 1))))
(let ((samps (channel->float-vector 0 20))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(set! (v 7) .95)
(set! (v 10) .125)
- (if (not (vequal samps v))
+ (if (not (mus-arrays-equal? samps v))
(snd-display ";mix 2->1 at 5: ~A ~A" samps v)))
(if (not (mix? tag)) (snd-display ";mix 2->1 at 5 tag: ~A" tag))
(undo))
@@ -22223,44 +22023,44 @@ EDITS: 2
(insert-silence 0 20 ind 0)
(insert-silence 0 20 ind 1)
(let ((tag (car (mix "test.snd" 0 #t))))
- (let ((v (make-float-vector 20 0.0)))
+ (let ((v (make-float-vector 20)))
(set! (v 2) .95)
(set! (v 5) .125)
(let ((samps1 (channel->float-vector 0 20 ind 1)))
- (if (not (vequal samps1 v))
+ (if (not (mus-arrays-equal? samps1 v))
(snd-display ";mix 1->1 (2): ~A ~A" samps1 v)))
(set! (v 2) .5)
(set! (v 5) .25)
(let ((samps0 (channel->float-vector 0 20 ind 0)))
- (if (not (vequal samps0 v))
+ (if (not (mus-arrays-equal? samps0 v))
(snd-display ";mix 1->1 (3): ~A ~A" samps0 v))))
(if (not (mix? tag)) (snd-display ";mix 1->1 tag: ~A" tag)))
(undo 1 ind 0)
(undo 1 ind 1)
(let ((tag (mix "test.snd" 0 1 ind 1 #f))) ; samp:0, in-chan: 1
(let ((samps1 (channel->float-vector 0 20 ind 1))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(let ((samps0 (channel->float-vector 0 20 ind 0)))
- (if (not (vequal samps0 v))
+ (if (not (mus-arrays-equal? samps0 v))
(snd-display ";mix 1->1 (4): ~A ~A" samps0 v)))
(set! (v 2) .95)
(set! (v 5) .125)
- (if (not (vequal samps1 v))
+ (if (not (mus-arrays-equal? samps1 v))
(snd-display ";mix 1->1 (5): ~A ~A" samps1 v)))
(if (mix? tag) (snd-display ";mix 1->1 tag (5): ~A" tag)))
(undo 1 ind 1)
(set! (sync ind) 1)
(mix "test.snd" 0 #t)
(let ((samps1 (channel->float-vector 0 20 ind 1))
- (v (make-float-vector 20 0.0)))
+ (v (make-float-vector 20)))
(let ((samps0 (channel->float-vector 0 20 ind 0)))
(set! (v 2) .5)
(set! (v 5) .25)
- (if (not (vequal samps0 v))
+ (if (not (mus-arrays-equal? samps0 v))
(snd-display ";mix 1->1 (6): ~A ~A" samps0 v)))
(set! (v 2) .95)
(set! (v 5) .125)
- (if (not (vequal samps1 v))
+ (if (not (mus-arrays-equal? samps1 v))
(snd-display ";mix 1->1 (7): ~A ~A" samps1 v)))
(undo)
(close-sound ind))
@@ -22435,17 +22235,15 @@ EDITS: 2
(old-color *mix-color*))
(set! *mix-color* (make-color-with-catch 1 1 0))
(let ((mix1 (mix-float-vector (make-float-vector 10 .5) 10)))
- (if (not (and (or (equal? (color->list *mix-color*) (list 1.0 1.0 0.0))
- (equal? (color->list *mix-color*) (list 1.0 1.0 0.0 1.0)))
- (or (equal? (color->list (mix-color mix1)) (list 1.0 1.0 0.0))
- (equal? (color->list (mix-color mix1)) (list 1.0 1.0 0.0 1.0)))))
+ (if (not (and (member (color->list *mix-color*) '((1.0 1.0 0.0) (1.0 1.0 0.0 1.0)))
+ (member (color->list (mix-color mix1)) '((1.0 1.0 0.0) (1.0 1.0 0.0 1.0)))))
(snd-display ";set mix-color: ~A ~A ~A ~A"
- (color->list *mix-color*) (color->list (mix-color mix1)) (list 1.0 1.0 0.0) (color->list old-color)))
+ (color->list *mix-color*) (color->list (mix-color mix1)) '(1.0 1.0 0.0) (color->list old-color)))
(set! *mix-color* old-color)
(save-mix mix1 "test1.snd")
(let ((ind1 (open-sound "test1.snd")))
(if (not (= (framples ind1) (mix-length mix1))) (snd-display ";save-mix framples: ~A ~A" (mix-length mix1) (framples ind1)))
- (if (not (vequal (channel->float-vector 0 10) (mix->float-vector mix1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (mix->float-vector mix1)))
(snd-display ";save-mix data: ~A ~A" (mix->float-vector mix1) (channel->float-vector 0 10 ind1)))
(define mix7 (integer->mix 71231))
@@ -22477,48 +22275,48 @@ EDITS: 2
(id (mix-float-vector (make-float-vector 5 .5) 11)))
;; pad-channel
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11: ~A" (channel->float-vector 10 10)))
(pad-channel 0 10)
(if (not (mix? id))
(snd-display ";pad locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 21))
(snd-display ";float-vector .5 at 21 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 21: ~A" (channel->float-vector 20 10)))
- (if (not (vequal (channel->float-vector 10 10) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (make-float-vector 10)))
(snd-display ";float-vector .5 at 21 at 10: ~A" (channel->float-vector 10 10)))
(pad-channel 30 10)
(if (not (mix? id))
(snd-display ";pad 30 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 21))
(snd-display ";float-vector .5 at 21 position 30: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 21 30: ~A" (channel->float-vector 20 10)))
(pad-channel 150 10)
(if (not (mix? id))
(snd-display ";pad 150 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 21))
(snd-display ";float-vector .5 at 21 position 150: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 20 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 21 150: ~A" (channel->float-vector 20 10)))
(pad-channel 20 10)
(if (not (mix? id))
(snd-display ";pad 20 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 31))
(snd-display ";float-vector .5 at 31 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 30 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 30 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 31: ~A" (channel->float-vector 30 10)))
(pad-channel 32 3)
; (if (mix? id) (snd-display ";pad within mix but exists?: ~A" (mix? id)))
(if (not (mix? id)) (snd-display ";pad within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 30 10) (float-vector 0 .5 0 0 0 .5 .5 .5 .5 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 30 10) (float-vector 0 .5 0 0 0 .5 .5 .5 .5 0)))
(snd-display ";float-vector .5 at 31 pad at 32: ~A" (channel->float-vector 30 10)))
(set! (edit-position) 1)
(if (not (mix? id)) (snd-display ";mix float-vector after reset edit position: ~A" (mix? id)))
(if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 after reset edit: ~A" (channel->float-vector 10 10)))
;; delete
@@ -22527,25 +22325,25 @@ EDITS: 2
(snd-display ";delete locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 1))
(snd-display ";float-vector .5 at 1 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 1: ~A" (channel->float-vector 0 10)))
(delete-samples 30 10)
(if (not (mix? id))
(snd-display ";delete 30 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 1))
(snd-display ";float-vector .5 at 1 position del 30: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 1 del 30: ~A" (channel->float-vector 0 10)))
(delete-samples 3 3)
; (if (mix? id) (snd-display ";delete within mix but exists?: ~A" (mix? id)))
(if (not (mix? id)) (snd-display ";delete within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0 .5 .5 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (float-vector 0 .5 .5 0 0 0 0 0 0 0)))
(snd-display ";float-vector .5 at 1 del at 3: ~A" (channel->float-vector 0 10)))
(set! (edit-position) 1)
(if (not (mix? id)) (snd-display ";mix float-vector after del reset edit position: ~A" (mix? id)))
(if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after del reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 after del reset edit: ~A" (channel->float-vector 10 10)))
;; change
@@ -22554,25 +22352,25 @@ EDITS: 2
(snd-display ";set locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 set position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 set: ~A" (channel->float-vector 10 10)))
(set! (samples 20 5) (make-float-vector 5 .7))
(if (not (mix? id))
(snd-display ";set 20 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 set 20 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 set 20: ~A" (channel->float-vector 10 10)))
(set! (samples 12 2) (float-vector -.5 .8))
; (if (mix? id) (snd-display ";set within mix but exists?: ~A" (mix? id)))
(if (not (mix? id)) (snd-display ";set within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 -.5 .8 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 -.5 .8 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 set at 12: ~A" (channel->float-vector 10 10)))
(set! (edit-position) 1)
(if (not (mix? id)) (snd-display ";mix float-vector after set reset edit position: ~A" (mix? id)))
(if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after set reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 after set reset edit: ~A" (channel->float-vector 10 10)))
;; scale
@@ -22581,39 +22379,39 @@ EDITS: 2
(snd-display ";scale locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 scale position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 1 1 1 1 1 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 1 1 1 1 1 0 0 0 0)))
(snd-display ";float-vector 1 at 11 scale: ~A" (channel->float-vector 10 10)))
(scale-channel 0.5)
(if (not (mix? id))
(snd-display ";unscale locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 unscale position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector 1 at 11 unscale: ~A" (channel->float-vector 10 10)))
(scale-channel -1.0 0 5)
(if (not (mix? id))
(snd-display ";scale at 0 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 scale at 0 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector 1 at 11 scale at 0: ~A" (channel->float-vector 10 10)))
(scale-channel -1.0 22 10)
(if (not (mix? id))
(snd-display ";scale at 22 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 scale at 22 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector 1 at 11 scale at 22: ~A" (channel->float-vector 10 10)))
(scale-channel 2.0 12 2)
; (if (mix? id) (snd-display ";scale within mix but exists?: ~A" (mix? id)))
(if (not (mix? id)) (snd-display ";scale within mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 1 1 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 1 1 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 scale at 12: ~A" (channel->float-vector 10 10)))
(set! (edit-position) 1)
(if (not (mix? id)) (snd-display ";mix float-vector after scale reset edit position: ~A" (mix? id)))
(if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after scale reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 after scale reset edit: ~A" (channel->float-vector 10 10)))
;; envelopes
@@ -22622,30 +22420,30 @@ EDITS: 2
(snd-display ";env locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 env position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector 1 at 11 env: ~A" (channel->float-vector 10 10)))
(env-channel '(0 0 1 1) 17 10)
(if (not (mix? id))
(snd-display ";env 17 locked mix? ~A" (mix? id)))
(if (not (= (mix-position id) 11))
(snd-display ";float-vector .5 at 11 env 17 position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector 1 at 11 env 17: ~A" (channel->float-vector 10 10)))
(env-channel '(0 0 1 1))
; (if (mix? id) (snd-display ";env over mix but exists?: ~A" (mix? id)))
(if (not (mix? id)) (snd-display ";env over mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0.000 0.056 0.061 0.066 0.071 0.076 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0.000 0.056 0.061 0.066 0.071 0.076 0.000 0.000 0.000 0.000)))
(snd-display ";float-vector .5 at 11 over env: ~A" (channel->float-vector 10 10)))
(set! (edit-position) 1)
; (if (not (mix? id)) (snd-display ";mix float-vector after env reset edit position: ~A" (mix? id)))
(if (not (= (mix-position id) 11)) (snd-display ";mix float-vector position after env reset edit position: ~A" (mix-position id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 .5 .5 .5 .5 .5 0 0 0 0)))
(snd-display ";float-vector .5 at 11 after env reset edit: ~A" (channel->float-vector 10 10)))
(scale-by 0.0)
(if (not (mix? id)) (snd-display ";zero mix but no mix?: ~A" (mix? id)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";float-vector 1 at 11 scale 0: ~A" (channel->float-vector 10 10)))
(undo 2)
@@ -22654,7 +22452,7 @@ EDITS: 2
((= i 5))
(set! ids (cons (mix-float-vector (make-float-vector 5 .1) (+ i 10)) ids)))
(let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
(snd-display ";pile up mixes: ~A" vals)))
(let ((mx (mixes-maxamp ids)))
(if (fneq mx .1)
@@ -22669,15 +22467,15 @@ EDITS: 2
(scale-mixes ids -2.0)
(for-each (lambda (m) (if (fneq (mix-amp m) -2.0) (snd-display ";scale-mixes ~A: ~A" m (mix-amp m)))) ids)
(let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 -0.200 -0.400 -0.600 -0.800 -1.000 -0.800 -0.600 -0.400 -0.200 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 -0.200 -0.400 -0.600 -0.800 -1.000 -0.800 -0.600 -0.400 -0.200 0.000 0.000 0.000)))
(snd-display ";scale piled up mixes: ~A" vals)))
(silence-mixes ids)
(let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (make-float-vector 14 0.0)))
+ (if (not (mus-arrays-equal? vals (make-float-vector 14)))
(snd-display ";silence piled up mixes: ~A" vals)))
(undo 2)
(let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
(snd-display ";undo 2 to pile up mixes: ~A" vals)))
(play-mixes ids)
(set-mixes-tag-y ids 100)
@@ -22685,17 +22483,17 @@ EDITS: 2
(set-mixes-tag-y ids 0)
(move-mixes ids 10)
(let ((vals (channel->float-vector 18 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
(snd-display ";move piled up mixes: ~A" vals)))
(let ((vals (channel->float-vector 8 8)))
- (if (not (vequal vals (make-float-vector 8 0.0)))
+ (if (not (mus-arrays-equal? vals (make-float-vector 8)))
(snd-display ";move piled up mixes original: ~A" vals)))
(move-mixes ids -10)
(let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
(snd-display ";move piled up mixes -10: ~A" vals)))
(let ((vals (channel->float-vector 23 8)))
- (if (not (vequal vals (make-float-vector 8 0.0)))
+ (if (not (mus-arrays-equal? vals (make-float-vector 8)))
(snd-display ";move piled up mixes -10: ~A" vals)))
(for-each (lambda (m) (set! (mix-sync m) 24)) ids)
(let ((mxs (syncd-mixes 24)))
@@ -22705,33 +22503,33 @@ EDITS: 2
(sync-all-mixes 0)
(env-mixes ids '(0 0 1 1 2 0))
(let ((vals (channel->float-vector 10 10)))
- (if (not (vequal vals (float-vector 0.000 0.045 0.137 0.278 0.460 0.360 0.203 0.087 0.020 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.045 0.137 0.278 0.460 0.360 0.203 0.087 0.020 0.000)))
(snd-display ";env-mixes: ~A" vals)))
(undo 3)
(let ((vals (channel->float-vector 8 14)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000 0.000 0.000)))
(snd-display ";undo 3 mixes envd: ~A" vals)))
(color-mixes ids (make-color 0 1 0))
(scale-tempo ids 2.0)
(let ((begs (map mix-position ids)))
- (if (not (equal? begs (list 18 16 14 12 10)))
+ (if (not (equal? begs '(18 16 14 12 10)))
(snd-display ";scale-tempo by 2: ~A" begs)))
(let ((vals (channel->float-vector 10 15)))
- (if (not (vequal vals (float-vector 0.100 0.100 0.200 0.200 0.300 0.200 0.300 0.200 0.300 0.200 0.200 0.100 0.100 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.100 0.100 0.200 0.200 0.300 0.200 0.300 0.200 0.300 0.200 0.200 0.100 0.100 0.000 0.000)))
(snd-display ";scale-tempo 2 vals: ~A" vals)))
(scale-tempo ids 0.5)
(let ((begs (map mix-position ids)))
- (if (not (equal? begs (list 14 13 12 11 10)))
+ (if (not (equal? begs '(14 13 12 11 10)))
(snd-display ";scale-tempo by 0.5: ~A" begs)))
(let ((vals (channel->float-vector 10 10)))
- (if (not (vequal vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100 0.000)))
(snd-display ";scale-tempo back 0.5: ~A" vals)))
(scale-tempo ids -1.0)
(let ((begs (map mix-position ids)))
- (if (not (equal? begs (list 6 7 8 9 10)))
+ (if (not (equal? begs '(6 7 8 9 10)))
(snd-display ";scale-tempo by -1: ~A" begs)))
(let ((vals (channel->float-vector 0 15)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.100 0.200 0.300 0.400 0.500 0.400 0.300 0.200 0.100)))
(snd-display ";scale-tempo -1 vals: ~A" vals)))
(undo 3)
(set! *sinc-width* 10)
@@ -22741,9 +22539,9 @@ EDITS: 2
(if (not (= (mixes-length ids) 15))
(snd-display ";src-mixes length: ~A" (mixes-length ids)))
(let ((vals (channel->float-vector 10 15)))
- (if (not (vequal vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
(snd-display ";src-mixes 0.5 vals: ~A" vals)))
- (if (not (vequal (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
+ (if (not (mus-arrays-equal? (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
(snd-display ";src-mixes vals don't match: ~A ~A" (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
(undo)
(transpose-mixes ids -12)
@@ -22752,9 +22550,9 @@ EDITS: 2
(if (not (= (mixes-length ids) 15))
(snd-display ";transpose-mixes length: ~A" (mixes-length ids)))
(let ((vals (channel->float-vector 10 15)))
- (if (not (vequal vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.100 0.211 0.311 0.408 0.508 0.505 0.495 0.505 0.508 0.460 0.362 0.262 0.152 0.052 0.000)))
(snd-display ";transpose-mixes 0.5 vals: ~A" vals)))
- (if (not (vequal (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
+ (if (not (mus-arrays-equal? (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
(snd-display ";transpose-mixes vals don't match: ~A ~A" (mix->float-vector (car ids)) (mix->float-vector (cadr ids))))
(revert-sound))
(close-sound ind))
@@ -22815,7 +22613,7 @@ EDITS: 2
(env-channel '(0 0 1 1))
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576)))
(snd-display ";mix on env: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on env: ~A ~A" id (mix? id))))
@@ -22826,14 +22624,14 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.485 0.495 0.605 0.715 0.825 0.535 0.545 0.556 0.566 0.576))))
(snd-display ";read mix on env reversed: ~A" data)))
(undo)
(env-channel '(0 0 1 1))
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331)))
(snd-display ";mix on env 1: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on env 1: ~A ~A" id (mix? id))))
@@ -22844,14 +22642,14 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.235 0.245 0.355 0.465 0.576 0.287 0.298 0.309 0.320 0.331))))
(snd-display ";read mix on env1 reversed: ~A" data)))
(undo)
(env-channel '(0 0 1 1))
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191)))
(snd-display ";mix on env 2: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on env 2: ~A ~A" id (mix? id))))
@@ -22862,14 +22660,14 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.114 0.121 0.229 0.337 0.445 0.153 0.162 0.171 0.181 0.191))))
(snd-display ";read mix on env2 reversed: ~A" data)))
(undo)
(env-channel '(0 0 1 1))
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110)))
(snd-display ";mix on env 3: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on env 3: ~A ~A" id (mix? id))))
@@ -22880,14 +22678,14 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.055 0.060 0.165 0.270 0.376 0.082 0.089 0.095 0.102 0.110))))
(snd-display ";read mix on env3 reversed: ~A" data)))
(undo)
(env-channel '(0 0 1 1))
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063)))
(snd-display ";mix on env 4: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on env 4: ~A ~A" id (mix? id))))
@@ -22898,7 +22696,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.027 0.030 0.133 0.236 0.340 0.044 0.048 0.053 0.058 0.063))))
(snd-display ";read mix on env4 reversed: ~A" data)))
(undo)
@@ -22906,7 +22704,7 @@ EDITS: 2
(xramp-channel 1 0 32.0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108)))
(snd-display ";mix on xramp: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp: ~A ~A" id (mix? id))))
@@ -22917,7 +22715,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.160 0.153 0.247 0.341 0.435 0.129 0.124 0.118 0.113 0.108))))
(snd-display ";read mix on xramp reversed: ~A" data)))
(set! (edit-position ind 0) 1)
@@ -22925,7 +22723,7 @@ EDITS: 2
(xramp-channel 1 0 32.0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012)))
(snd-display ";mix on xramp2: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp2: ~A ~A" id (mix? id))))
@@ -22936,7 +22734,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.026 0.024 0.122 0.220 0.318 0.017 0.015 0.014 0.013 0.012))))
(snd-display ";read mix on xramp2 reversed: ~A" data)))
(set! (edit-position ind 0) 1)
@@ -22945,7 +22743,7 @@ EDITS: 2
(ramp-channel 1 0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005)))
(snd-display ";mix on xramp2_ramp: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp2_ramp: ~A ~A" id (mix? id))))
@@ -22956,7 +22754,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.013 0.012 0.111 0.210 0.309 0.008 0.007 0.006 0.006 0.005))))
(snd-display ";read mix on xramp2_ramp reversed: ~A" data)))
(set! (edit-position ind 0) 1)
@@ -22966,7 +22764,7 @@ EDITS: 2
(ramp-channel 1 0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002)))
(snd-display ";mix on xramp2_ramp2: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp2_ramp2: ~A ~A" id (mix? id))))
@@ -22977,7 +22775,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.007 0.006 0.105 0.205 0.304 0.004 0.003 0.003 0.002 0.002))))
(snd-display ";read mix on xramp2_ramp2 reversed: ~A" data)))
(set! (edit-position ind 0) 1)
@@ -22985,7 +22783,7 @@ EDITS: 2
(ramp-channel 1 0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046)))
(snd-display ";mix on xramp_ramp: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp_ramp: ~A ~A" id (mix? id))))
@@ -22996,7 +22794,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.082 0.077 0.173 0.268 0.364 0.060 0.056 0.053 0.049 0.046))))
(snd-display ";read mix on xramp_ramp reversed: ~A" data)))
(set! (edit-position ind 0) 1)
@@ -23005,7 +22803,7 @@ EDITS: 2
(ramp-channel 1 0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019)))
(snd-display ";mix on xramp_ramp2: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp_ramp2: ~A ~A" id (mix? id))))
@@ -23016,7 +22814,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.042 0.039 0.136 0.233 0.330 0.028 0.026 0.023 0.021 0.019))))
(snd-display ";read mix on xramp_ramp2 reversed: ~A" data)))
(set! (edit-position ind 0) 1)
@@ -23026,7 +22824,7 @@ EDITS: 2
(ramp-channel 1 0)
(let ((id (mix-float-vector (float-vector .1 .2 .3) 50)))
(let ((vals (channel->float-vector 48 10)))
- (if (not (vequal vals (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008)))
(snd-display ";mix on xramp_ramp3: ~A" vals)))
(if (and tag (not (mix? id)))
(snd-display ";mix on xramp_ramp3: ~A ~A" id (mix? id))))
@@ -23037,7 +22835,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (data i) (read-sample reader)))
- (if (not (vequal data (reverse! (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008))))
+ (if (not (mus-arrays-equal? data (reverse! (float-vector 0.022 0.020 0.118 0.216 0.314 0.013 0.012 0.010 0.009 0.008))))
(snd-display ";read mix on xramp_ramp3 reversed: ~A" data)))
(set! *with-mix-tags* #t)
@@ -23045,7 +22843,7 @@ EDITS: 2
(mix-float-vector (float-vector .1 .2 .3) 50)
(reverse-sound)
(let ((vals (channel->float-vector 45 8)))
- (if (not (vequal vals (float-vector 0.000 0.000 0.300 0.200 0.100 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.000 0.300 0.200 0.100 0.000 0.000 0.000)))
(snd-display ";reversed mix vals: ~A" vals)))
(close-sound ind))
@@ -23208,7 +23006,7 @@ EDITS: 2
(let ((spd (mix-speed mix-id)))
(if (fneq spd 1.0) (snd-display ";mix-speed: ~A?" spd)))
(let ((nam (mix-name mix-id)))
- (if (not (equal? nam "")) (snd-display ";mix-name: ~A" nam)))
+ (if (not (string=? nam "")) (snd-display ";mix-name: ~A" nam)))
(catch 'mus-error
(lambda () (play mix-id))
(lambda args (snd-display ";can't play mix: ~A" args)))
@@ -23216,17 +23014,15 @@ EDITS: 2
(lambda () (play mix-id 1000))
(lambda args (snd-display ";can't play mix from 1000: ~A" args)))
(set! (mix-name mix-id) "test-mix")
- (if (not (and (string? (mix-name mix-id))
- (string=? (mix-name mix-id) "test-mix")))
+ (if (not (string=? (mix-name mix-id) "test-mix"))
(snd-display ";mix-name set: ~A" (mix-name mix-id)))
(let ((id (mix-name->id "test-mix")))
(if (not (equal? id mix-id)) (snd-display ";mix-name->id: ~A ~A" id mix-id)))
(set! (mix-name mix-id) "test-mix-again") ; make sure previous name is freed
- (if (not (and (string? (mix-name mix-id))
- (string=? (mix-name mix-id) "test-mix-again")))
+ (if (not (string=? (mix-name mix-id) "test-mix-again"))
(snd-display ";mix-name set again: ~A" (mix-name mix-id)))
(set! (mix-name mix-id) "")
- (if (not (equal? (mix-name mix-id) "")) (snd-display ";set mix-name #f: ~A" (mix-name mix-id)))
+ (if (not (string=? (mix-name mix-id) "")) (snd-display ";set mix-name #f: ~A" (mix-name mix-id)))
(set! (mix-position mix-id) 200)
(set! (mix-amp mix-id) 0.5)
(set! (mix-speed mix-id) 2.0)
@@ -23343,8 +23139,7 @@ EDITS: 2
(snd-display ";pan-mix-float-vector 1->2 env 1: ~A" (mix-amp-env id1)))
(revert-sound ind))
- (let* ((reg (make-region 0 50 ind 0))
- (ids (pan-mix-region reg 100 '(0 0 1 1)))
+ (let* ((ids (pan-mix-region (make-region 0 50 ind 0) 100 '(0 0 1 1)))
(id0 (car ids))
(id1 (cadr ids)))
(if (not (and (mix? id0) (mix? id1)))
@@ -23377,8 +23172,8 @@ EDITS: 2
(close-sound ind))
;; copy mix
- (let* ((snd (new-sound "test.snd"))
- (v (make-float-vector 1000)))
+ (let ((snd (new-sound "test.snd"))
+ (v (make-float-vector 1000)))
(do ((i 0 (+ i 1)))
((= i 1000))
(set! (v i) (* i .001)))
@@ -23459,8 +23254,7 @@ EDITS: 2
" (set! m (add-mark ~A #f ~D ~A ~D))~%"
(mark-sample m)
chan
- (and (string? (mark-name m))
- (> (length (mark-name m)) 0)
+ (and (> (length (mark-name m)) 0)
(format #f "~S" (mark-name m)))
(mark-sync m))))
(if (pair? (mark-properties m))
@@ -23767,7 +23561,7 @@ EDITS: 2
(if (sound? s2) (close-sound s2)))
(let ((fd (open-sound "pistol.snd")))
(let ((file (save-marks)))
- (if file
+ (if (string? file)
(snd-display ";save-marks no marks -> ~A?" file)))
(close-sound fd))
(let ((fd (open-sound "oboe.snd")))
@@ -23785,7 +23579,7 @@ EDITS: 2
(if (not (equal? (marks fd 0) (reverse (marks fd 0 0))))
(snd-display ";src rev marks: ~A ~A ~A" ms (marks fd 0) (reverse (marks fd 0 0))))
(let ((ms1 (map mark-sample (marks fd 0))))
- (if (not (equal? ms1 (list 7998 96654 99654))) ; off-by-1 somewhere...
+ (if (not (equal? ms1 '(7998 96654 99654))) ; off-by-1 somewhere...
(snd-display ";src rev mark locs: ~A" ms1))))
(close-sound fd))
(let ((fd (open-sound "4.aiff")))
@@ -24028,9 +23822,7 @@ EDITS: 2
(delete-samples beg dur)
(for-each
(lambda (id old-loc)
- (cond ((and (> old-loc beg)
- (< old-loc end)
- (mark? id))
+ (cond ((and (< beg old-loc end) (mark? id))
(snd-display ";delete did not clobber mark: ~A ~A [~A ~A]" id old-loc beg end))
((and (> old-loc end)
(not (= (mark-sample id) (- old-loc dur))))
@@ -24147,13 +23939,13 @@ EDITS: 2
(if (not m11) (snd-display ";can't find 11th mark")
(if (not (= (mark-sample m11 1) 23)) (snd-display ";mark 11th: ~A" (mark-sample m11 1))))
(if (mark? m12) (snd-display ";found 12th mark: ~A ~A ~A" m12 (mark-sample m12 2) (mark-name m12))))
- (set! (mark-name m1) #f))
+ (set! (mark-name m1) ""))
(close-sound ind))
(if (string? sf-dir)
(let ((ind (open-sound (string-append sf-dir "forest.aiff"))))
(mark-loops)
(let ((pos (map mark-sample (marks ind 0))))
- (if (not (equal? pos (list 24981 144332)))
+ (if (not (equal? pos '(24981 144332)))
(snd-display ";forest marked loops: ~A ~A" (marks ind 0) pos)))
(close-sound ind)))
@@ -24230,7 +24022,7 @@ EDITS: 2
(m2 (find-mark 2 ind 1)))
(if (not (and (mark? m1) (mark? m2)))
(snd-display ";save-marks 2a 1,2: ~A ~A" m1 m2)
- (if (not (and (= (mark-sync m1) 0) (= (mark-sync m2) 0)))
+ (if (not (= (mark-sync m1) 0 (mark-sync m2)))
(snd-display ";save-marks 2a 1,2 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))))
(let ((m1 (find-mark 5 ind 0))
(m2 (find-mark 10 ind 1)))
@@ -24254,7 +24046,7 @@ EDITS: 2
(if (not (and (mark? m1) (mark? m2)))
(snd-display ";save-marks 2a 3,6: ~A ~A" m1 m2)
(begin
- (if (not (and (= (mark-sync m1) 0) (= (mark-sync m2) 0)))
+ (if (not (= (mark-sync m1) 0 (mark-sync m2)))
(snd-display ";save-marks 2a 3,6 syncs: ~A ~A" (mark-sync m1) (mark-sync m2)))
(if (not (string=? (mark-name m1) "hi3")) (snd-display ";save-marks 2a 3 name: ~A" (mark-name m1)))
(if (not (string=? (mark-name m2) "hi6")) (snd-display ";save-marks 2a 6 name: ~A" (mark-name m2))))))
@@ -24317,21 +24109,21 @@ EDITS: 2
(snd-display ";mark-explode did not write mark-0.snd?")
(let ((ind1 (open-sound "mark-0.snd")))
(if (not (= (framples ind1 0) 10)) (snd-display ";mark-0 framples: ~A" (framples ind1 0)))
- (if (not (vequal (channel->float-vector) (make-float-vector 10 .1))) (snd-display ";mark-0 vals: ~A" (channel->float-vector)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (make-float-vector 10 .1))) (snd-display ";mark-0 vals: ~A" (channel->float-vector)))
(close-sound ind1)
(delete-file "mark-0.snd")))
(if (not (file-exists? "mark-1.snd"))
(snd-display ";mark-explode did not write mark-1.snd?")
(let ((ind1 (open-sound "mark-1.snd")))
(if (not (= (framples ind1 0) 10)) (snd-display ";mark-1 framples: ~A" (framples ind1 0)))
- (if (not (vequal (channel->float-vector) (make-float-vector 10 .4))) (snd-display ";mark-1 vals: ~A" (channel->float-vector)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (make-float-vector 10 .4))) (snd-display ";mark-1 vals: ~A" (channel->float-vector)))
(close-sound ind1)
(delete-file "mark-1.snd")))
(if (not (file-exists? "mark-2.snd"))
(snd-display ";mark-explode did not write mark-2.snd?")
(let ((ind1 (open-sound "mark-2.snd")))
(if (not (= (framples ind1 0) 10)) (snd-display ";mark-2 framples: ~A" (framples ind1 0)))
- (if (not (vequal (channel->float-vector) (make-float-vector 10 .8))) (snd-display ";mark-2 vals: ~A" (channel->float-vector)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (make-float-vector 10 .8))) (snd-display ";mark-2 vals: ~A" (channel->float-vector)))
(close-sound ind1)
(delete-file "mark-2.snd")))
(if (file-exists? "mark-3.snd") (snd-display ";mark-explode wrote too many files?"))
@@ -24380,7 +24172,7 @@ EDITS: 2
(help-dialog "Test" "snd-test here")
(save-envelopes "hiho.env")
(load (string-append cwd "hiho.env"))
- (if (not (equal? env4 (list 0.0 1.0 1.0 0.0))) (snd-display ";save-envelopes: ~A?" env4))
+ (if (not (equal? env4 '(0.0 1.0 1.0 0.0))) (snd-display ";save-envelopes: ~A?" env4))
(delete-file "hiho.env")
(help-dialog "test2" "this is the next test"
(list "string 1{open-sound}" "{env-sound}string2" "string{close-sound}3")
@@ -24412,15 +24204,13 @@ EDITS: 2
(snd-display ";snd-help 'enved-base: ~A?" (snd-help 'enved-base)))
(if (not (string-equal-ignoring-white-space (snd-help "enved-base") "(enved-base): envelope editor exponential base value (1.0)"))
(snd-display ";snd-help \"enved-base\": ~A?" (snd-help "enved-base")))
- (let ((old-val hamming-window))
- (let ((str1 (snd-help 'hamming-window))
- (str2 (snd-help "hamming-window")))
- (if (not (and (string? str1) (string? str2)
- (string-equal-ignoring-white-space str1 str2)
- (string-equal-ignoring-white-space str1 "A raised cosine")))
- (snd-display ";snd-help hamming-window: ~A ~A" str1 str2)))
- (if (not (= hamming-window old-val))
- (snd-display ";snd-help clobbered out-of-module variable: ~A ~A" old-val hamming-window)))
+ (let ((str1 (snd-help 'hamming-window))
+ (str2 (snd-help "hamming-window")))
+ (if (not (and (string? str1) (string? str2)
+ (string-equal-ignoring-white-space str1 str2)
+ (string-equal-ignoring-white-space str1 "A raised cosine")))
+ (snd-display ";snd-help hamming-window: ~A ~A" str1 str2)))
+
(let ((vals (snd-urls)))
(do ((i 0 (+ i 1)))
((= i 25)) ; need to cycle the 8's
@@ -24452,7 +24242,7 @@ EDITS: 2
(let ((vfsort1 (view-files-sort dialog)))
(if (not (= vfsort1 0)) (snd-display ";vf sort(d): ~A" vfsort1)))
(let ((vfe (view-files-amp-env dialog)))
- (if (not (feql vfe (list 0.0 1.0 1.0 1.0))) (snd-display ";vf amp env: ~A" vfe)))
+ (if (not (feql vfe '(0.0 1.0 1.0 1.0))) (snd-display ";vf amp env: ~A" vfe)))
(let ((vffiles (view-files-files dialog)))
(if (not (list? vffiles)) (snd-display ";vf files: ~A" vffiles)))
(let ((vfsel (view-files-selected-files dialog)))
@@ -24494,7 +24284,7 @@ EDITS: 2
(equal? selected-file (string-append home-dir "/cl/1a.snd"))
(equal? selected-file (string-append home-dir "/snd-16/1a.snd"))))
(snd-display ";vf set selected select hook arg: ~A" selected-file))
- (if (not (or (equal? (view-files-selected-files dialog) (list "1a.snd"))
+ (if (not (or (equal? (view-files-selected-files dialog) '("1a.snd"))
(equal? (view-files-selected-files dialog) (list (string-append home-dir "/cl/1a.snd")))
(equal? (view-files-selected-files dialog) (list (string-append home-dir "/snd-16/1a.snd")))))
(snd-display ";vf selected files set: ~A" (view-files-selected-files dialog))))
@@ -24511,14 +24301,11 @@ EDITS: 2
(define (test-spectral-difference snd1 snd2 maxok)
(define (spectral-difference snd1 snd2)
- (let* ((size (max (framples snd1) (framples snd2)))
- (pow2 (ceiling (log size 2)))
- (fftlen (expt 2 pow2))
+ (let* ((fftlen (expt 2 (ceiling (log (max (framples snd1) (framples snd2)) 2))))
(fdr1 (channel->float-vector 0 fftlen snd1 0))
(fdr2 (channel->float-vector 0 fftlen snd2 0))
- (spectr1 (snd-spectrum fdr1 blackman2-window fftlen #t))
- (spectr2 (snd-spectrum fdr2 blackman2-window fftlen #t))
- (diffs (float-vector-subtract! spectr1 spectr2))
+ (diffs (float-vector-subtract! (snd-spectrum fdr1 blackman2-window fftlen #t)
+ (snd-spectrum fdr2 blackman2-window fftlen #t)))
(len (length diffs))
(incr (make-one-pole 1.0 -1.0)))
(float-vector-abs! diffs)
@@ -24553,8 +24340,7 @@ EDITS: 2
(lambda (file)
(catch 'mus-error
(lambda ()
- (if (and (< (mus-sound-chans (string-append sf-dir file)) 256)
- (> (mus-sound-chans (string-append sf-dir file)) 0)
+ (if (and (< 0 (mus-sound-chans (string-append sf-dir file)) 256)
(>= (mus-sound-sample-type (string-append sf-dir file)) 0)
(> (mus-sound-srate (string-append sf-dir file)) 0)
(>= (mus-sound-framples (string-append sf-dir file)) 0))
@@ -24607,8 +24393,7 @@ EDITS: 2
(set! open-ctr (+ open-ctr 1))
(set! open-files (cons fd open-files)))))
(if (and (> len 0) (> (random 1.0) 0.3))
- (let* ((choice (floor (random (* 1.0 (length open-files)))))
- (fd (open-files choice)))
+ (let ((fd (open-files (floor (random (* 1.0 (length open-files)))))))
(close-sound fd)
(set! open-files (remove-if (lambda (a) (equal? a fd)) open-files)))))))
(if (pair? open-files) (for-each close-sound open-files))
@@ -24755,8 +24540,8 @@ EDITS: 2
(if (> (mus-sound-chans file) 16)
(set! sfiles (cons file sfiles)))))
(if (and (file-exists? "s24.snd")
- (not (and (equal? ffiles (list "s24.snd"))
- (equal? sfiles (list "s24.snd")))))
+ (not (and (equal? ffiles '("s24.snd"))
+ (equal? sfiles '("s24.snd")))))
(snd-display ";map|for-each-sound-file(s): ~A ~A" ffiles sfiles)))
)
; (if sf-dir-files
@@ -24966,8 +24751,7 @@ EDITS: 2
(chn (hook 'chn))
(dur (hook 'duration)))
(if (mus-sound-maxamp-exists? (file-name snd))
- (let* ((amp-vals (mus-sound-maxamp (file-name snd)))
- (max-val (amp-vals (+ (* chn 2) 1))))
+ (let ((max-val ((mus-sound-maxamp (file-name snd)) (+ (* chn 2) 1)))) ; implicit index
(set! (hook 'result) (list 0.0 dur (- max-val) max-val)))
(set! (hook 'result) (list 0.0 dur -1.0 1.0))))))
(set! (hook-functions after-open-hook) ())
@@ -25054,17 +24838,20 @@ EDITS: 2
(if (not (= id 1043)) (snd-display ";ladspa .UniqueID: ~A" id))
(if (not (= count 4)) (snd-display ";ladspa .PortCount: ~A" count))
(if (not (= props 4)) (snd-display ";ladspa .Properties: ~A" prop))
- (if (not (equal? names (list "Delay (Seconds)" "Dry/Wet Balance" "Input" "Output")))
+ (if (not (equal? names '("Delay (Seconds)" "Dry/Wet Balance" "Input" "Output")))
(snd-display ";ladspa .PortNames: ~A" names))
- (if (not (equal? hints (list (list 579 0.0 5.0) (list 195 0.0 1.0) (list 0 0.0 0.0) (list 0 0.0 0.0))))
+ (if (not (equal? hints '((579 0.0 5.0) (195 0.0 1.0) (0 0.0 0.0) (0 0.0 0.0))))
(snd-display ";ladspa .PortRangeHints: ~A" hints))
- (if (not (equal? descs (list 5 5 9 10)))
+ (if (not (equal? descs '(5 5 9 10)))
(snd-display ";ladspa .PortDescriptors: ~A" descs))
(if (not (= (logand (cadr (.PortDescriptors ptr)) LADSPA_PORT_INPUT) 1))
(snd-display ";ladspa port hint: ~A" (logand (cadr (.PortDescriptors ptr)) LADSPA_PORT_INPUT))))
(apply-ladspa (make-sampler 0) (list "delay" "delay_5s" .3 .5) 1000 "delayed")
(if (not (equal? (analyze-ladspa "delay" "delay_5s")
- (list "Simple Delay Line" "Richard Furse (LADSPA example plugins)" "None" (list "Dry/Wet Balance" "minimum" 0.0 "maximum" 1.0) (list "Delay (Seconds)" "minimum" 0.0 "maximum" 5.0))))
+ '("Simple Delay Line" "Richard Furse (LADSPA example plugins)"
+ "None"
+ ("Dry/Wet Balance" "minimum" 0.0 "maximum" 1.0)
+ ("Delay (Seconds)" "minimum" 0.0 "maximum" 5.0))))
(snd-display ";analyze-ladspa: ~A" (analyze-ladspa "delay" "delay_5s")))
(ladspa-it "delay" "delay_5s" .3 .5)
(if (provided? 'xm)
@@ -25112,7 +24899,7 @@ EDITS: 2
(set! *ladspa-dir* "/home/bil/test/ladspa/vocoder-0.3")
(init-ladspa)
- (if (not (equal? (list-ladspa) (list (list "vocoder" "vocoder"))))
+ (if (not (equal? (list-ladspa) '(("vocoder" "vocoder"))))
(snd-display ";list-ladspa vocoder: ~A" (list-ladspa)))
(if (not (list? (analyze-ladspa "vocoder" "vocoder")))
(snd-display ";analyze-ladspa vocoder: ~A" (analyze-ladspa "vocoder" "vocoder")))
@@ -25172,9 +24959,9 @@ EDITS: 2
(key (char->integer #\0) 0 ind)
(key (char->integer #\x) 4 ind)
(key (char->integer #\z) 4 ind)
- (if (not (equal? (edit-fragment) (list "smooth-channel 2000 100" "set" 2000 100)))
+ (if (not (equal? (edit-fragment) '("smooth-channel 2000 100" "set" 2000 100)))
(snd-display ";C-x C-z fragment: ~A" (edit-fragment)))
- (if (not (vequal (channel->float-vector 2010 10) (float-vector 0.064 0.063 0.063 0.062 0.062 0.061 0.060 0.059 0.059 0.058)))
+ (if (not (mus-arrays-equal? (channel->float-vector 2010 10) (float-vector 0.064 0.063 0.063 0.062 0.062 0.061 0.060 0.059 0.059 0.058)))
(snd-display ";C-x C-z samps: ~A" (channel->float-vector 2010 10)))
(set! (cursor) 0)
(select-all)
@@ -25628,7 +25415,6 @@ EDITS: 2
(snd-error "uhoh")
(snd-warning "hiho")
- (mus-sound-samples "/bad/baddy")
(if (not se) (snd-display ";snd-error-hook not called?"))
(if (not sw) (snd-display ";snd-warning-hook not called?"))
@@ -25658,8 +25444,7 @@ EDITS: 2
(lambda (hook)
(let ((snd (hook 'snd))
(filename (hook 'name)))
- (if (not (and (string? filename)
- (string=? filename (mus-expand-filename "baddy.snd"))))
+ (if (not (equal? filename (mus-expand-filename "baddy.snd")))
(snd-display ";save-hook filename: ~A?" filename))
(if (not (equal? snd ind))
(snd-display ";save-hook snd: ~A ~A?" snd ind)))
@@ -25835,8 +25620,7 @@ EDITS: 2
(if (and (provided? 'snd-motif)
(provided? 'xm))
- (let* ((edhist ((channel-widgets ind 0) 7))
- (edp ((*motif* 'XtParent) edhist)))
+ (let ((edp ((*motif* 'XtParent) ((channel-widgets ind 0) 7))))
((*motif* 'XtUnmanageChild) edp)
((*motif* 'XtVaSetValues) edp (list (*motif* 'XmNpaneMinimum) 100))
((*motif* 'XtManageChild) edp)))
@@ -25888,8 +25672,7 @@ EDITS: 2
(if (and (provided? 'snd-motif)
(provided? 'xm))
- (let* ((edhist ((channel-widgets ind 0) 7))
- (edp ((*motif* 'XtParent) edhist)))
+ (let ((edp ((*motif* 'XtParent) ((channel-widgets ind 0) 7))))
((*motif* 'XtUnmanageChild) edp)
((*motif* 'XtVaSetValues) edp (list (*motif* 'XmNpaneMinimum) 1)) ; not 0 here -- Xt warnings
((*motif* 'XtManageChild) edp)))
@@ -26038,7 +25821,7 @@ EDITS: 2
(set! (fixed-vals 2) 0.0)
(set! (fixed-vals 6) 0.0)
(set! (fixed-vals 8) 0.0)
- (if (not (vequal fixed-vals new-vals))
+ (if (not (mus-arrays-equal? fixed-vals new-vals))
(snd-display ";clip-hook results:~% ~A~% ~A~% ~A" new-vals fixed-vals vals)))
(close-sound index)))
(set! *clipping* old-clip)
@@ -26095,12 +25878,10 @@ EDITS: 2
(reverse (sounds)))
(list sndlist chnlist))))))
(snd-display ";test-channel ~A: ~A ~A?" name val (apply map func (all-chans))))))
-
- (define duration
- (lambda (ind)
- (/ (framples ind) (srate ind))))
- (let* ((cur-dir-files (remove-if
+ (let* ((duration (lambda (ind)
+ (/ (framples ind) (srate ind))))
+ (cur-dir-files (remove-if
(lambda (file)
(<= (catch #t
(lambda ()
@@ -26196,700 +25977,689 @@ EDITS: 2
(snd-display ";save state restart from ~A to ~A sounds?" files (length (sounds))))
(set! open-files (sounds))))
- (let ()
- (let* ((choice (random cur-dir-len))
- (name (cur-dir-files choice))
- (ht (mus-sound-header-type name))
- (df (mus-sound-sample-type name))
- (fd (if (or (= ht mus-raw) (= df -1)) -1 (view-sound name))))
- (if (and (number? fd)
- (not (= fd -1)))
- (set! open-files (cons fd open-files))))
-
- (set! open-ctr (length open-files))
- (if (= open-ctr 0)
- (let ((fd (view-sound "1a.snd")))
- (set! open-ctr 1)
- (set! open-files (cons fd open-files))))
-
- (let ((choose-fd (lambda ()
- (if (zero? test-ctr) ; I think randomness here is messing up my timing comparisons
- (or (find-sound "1a.snd") (open-sound "1a.snd"))
- ((sounds) (random (length (sounds))))))))
- (let* (;(frame-list (map framples open-files))
- (curfd (choose-fd))
- (curloc (max 0 (min 1200 (framples curfd 0))))
- (old-marks (length (marks curfd 0))))
- ;(format *stderr* "~S (~A)~%" (file-name curfd) (duration curfd))
- (if (> (duration curfd) 0.0)
+ (let* ((name (cur-dir-files (random cur-dir-len)))
+ (fd (if (or (= (mus-sound-header-type name) mus-raw)
+ (= (mus-sound-sample-type name) -1))
+ -1
+ (view-sound name))))
+ (if (and (number? fd)
+ (not (= fd -1)))
+ (set! open-files (cons fd open-files))))
+
+ (set! open-ctr (length open-files))
+ (if (= open-ctr 0)
+ (let ((fd (view-sound "1a.snd")))
+ (set! open-ctr 1)
+ (set! open-files (cons fd open-files))))
+
+ (let ((choose-fd (lambda ()
+ (if (zero? test-ctr) ; I think randomness here is messing up my timing comparisons
+ (or (find-sound "1a.snd") (open-sound "1a.snd"))
+ ((sounds) (random (length (sounds))))))))
+ (let* ((curfd (choose-fd))
+ (curloc (max 0 (min 1200 (framples curfd 0))))
+ (old-marks (length (marks curfd 0))))
+ (if (> (duration curfd) 0.0)
+ (begin
+ (set! (x-bounds curfd) (list 0.0 (min (duration curfd) 1.0)))
+ (when with-gui
+ (let ((xb (x-bounds curfd)))
+ (if (or (fneq (car xb) 0.0)
+ (fneq (cadr xb) (min (duration curfd) 1.0)))
+ (snd-display ";x-bounds: ~A?" xb))))))
+ (set! (y-bounds curfd) (list -0.5 0.5))
+ (let ((yb (y-bounds curfd)))
+ (when (and with-gui
+ (or (fneq (car yb) -0.5) (fneq (cadr yb) 0.5)))
+ (snd-display ";y-bounds: ~A?" yb)))
+ (set! (cursor curfd 0) curloc)
+ (let ((cl (cursor curfd 0)))
+ (if (and (not (= cl curloc))
+ (> (framples curfd 0) curloc))
(begin
- (set! (x-bounds curfd) (list 0.0 (min (duration curfd) 1.0)))
- (when with-gui
- (let ((xb (x-bounds curfd)))
- (if (or (fneq (car xb) 0.0)
- (fneq (cadr xb) (min (duration curfd) 1.0)))
- (snd-display ";x-bounds: ~A?" xb))))))
- (set! (y-bounds curfd) (list -0.5 0.5))
- (let ((yb (y-bounds curfd)))
- (when (and with-gui
- (or (fneq (car yb) -0.5) (fneq (cadr yb) 0.5)))
- (snd-display ";y-bounds: ~A?" yb)))
- (set! (cursor curfd 0) curloc)
- (let ((cl (cursor curfd 0)))
- (if (and (not (= cl curloc))
- (> (framples curfd 0) curloc))
- (begin
- (snd-display ";cursor ~A is not ~A (framples: ~A)?" cl curloc (framples curfd 0))
- (set! curloc (cursor curfd 0)))))
- (if (>= curloc (framples curfd 0)) (set! curloc 0))
- (let ((id (catch #t (lambda () (add-mark curloc curfd)) (lambda args -1))))
- (when (and (number? id) (not (= id -1)))
- (let ((cl (mark-sample id)))
+ (snd-display ";cursor ~A is not ~A (framples: ~A)?" cl curloc (framples curfd 0))
+ (set! curloc (cursor curfd 0)))))
+ (if (>= curloc (framples curfd 0)) (set! curloc 0))
+ (let ((id (catch #t (lambda () (add-mark curloc curfd)) (lambda args -1))))
+ (when (and (number? id) (not (= id -1)))
+ (let ((cl (mark-sample id)))
+ (let ((new-marks (length (marks curfd 0))))
+ (if (not (= cl curloc)) (snd-display ";mark ~A is not ~A?" cl curloc))
+ (if (not (= new-marks (+ 1 old-marks))) (snd-display ";marks ~A ~A?" new-marks old-marks)))
+ (let ((new-id (find-mark curloc curfd)))
+ (if (not (and (mark? new-id)
+ (= id new-id)))
+ (snd-display ";find-mark (by sample): ~A ~A (~A for ~A ~A)?"
+ id new-id curloc (mark-sample id) (mark-sample new-id))))
+ (set! (mark-name id) "hiho")
+ (let ((new-id (find-mark "hiho" curfd)))
+ (if (not (and (mark? new-id)
+ (= id new-id)))
+ (snd-display ";find-mark (by name): ~A ~A?" id new-id)))
+ (if (not (string=? (mark-name id) "hiho")) (snd-display ";mark name: ~A?" (mark-name id)))
+ (set! (mark-sample id) (max 0 (- curloc 100)))
+ (set! cl (mark-sample id))
+ (if (not (= cl (max 0 (- curloc 100)))) (snd-display ";set mark ~A is not ~A?" cl curloc))
+ (delete-mark id)))
+ (if (> (duration curfd) 1.2) (set! (x-bounds curfd) '(1.0 1.1)))
+ (if (> (framples curfd) 25)
+ (begin
+ (add-mark 10 curfd)
+ (add-mark 20 curfd)
+ (key (char->integer #\m) 0 curfd)
+ (set! (cursor curfd) 0)
(let ((new-marks (length (marks curfd 0))))
- (if (not (= cl curloc)) (snd-display ";mark ~A is not ~A?" cl curloc))
- (if (not (= new-marks (+ 1 old-marks))) (snd-display ";marks ~A ~A?" new-marks old-marks)))
- (let ((new-id (find-mark curloc curfd)))
- (if (not (and (mark? new-id)
- (= id new-id)))
- (snd-display ";find-mark (by sample): ~A ~A (~A for ~A ~A)?"
- id new-id curloc (mark-sample id) (mark-sample new-id))))
- (set! (mark-name id) "hiho")
- (let ((new-id (find-mark "hiho" curfd)))
- (if (not (and (mark? new-id)
- (= id new-id)))
- (snd-display ";find-mark (by name): ~A ~A?" id new-id)))
- (if (not (string=? (mark-name id) "hiho")) (snd-display ";mark name: ~A?" (mark-name id)))
- (set! (mark-sample id) (max 0 (- curloc 100)))
- (set! cl (mark-sample id))
- (if (not (= cl (max 0 (- curloc 100)))) (snd-display ";set mark ~A is not ~A?" cl curloc))
- (delete-mark id)))
- (if (> (duration curfd) 1.2) (set! (x-bounds curfd) '(1.0 1.1)))
- (if (> (framples curfd) 25)
- (begin
- (add-mark 10 curfd)
- (add-mark 20 curfd)
- (key (char->integer #\m) 0 curfd)
- (set! (cursor curfd) 0)
- (let ((new-marks (length (marks curfd 0))))
- (delete-marks curfd)
- (if (> (duration curfd) 0.0)
- (set! (x-bounds curfd) (list 0.0 (min (duration curfd) 0.1))))
- (set! (y-bounds curfd) '(-1.0 1.0))
- (if (or (> (length (marks curfd 0)) 0)
- (not (= new-marks (+ old-marks 3))))
- (snd-display ";delete marks: ~A ~A?" new-marks old-marks)))))
- ))
-
- (revert-sound)
- (let ((old-setting *selection-creates-region*))
- (set! *selection-creates-region* #t)
- (let ((reg (select-all)))
- (without-errors
- (if (and (region? reg)
- (selection?))
- (let ((r1 (region-rms (car (regions))))
- (r2 (selection-rms)))
- (if (fneq r1 r2)
- (snd-display ";region rms: ~A?" r1))))))
- (set! *selection-creates-region* old-setting))
-
- (without-errors (if (region? (cadr (regions))) (play (cadr (regions)) :wait #t)))
- (without-errors (mix-region (car (regions))))
- (if (< (framples) 100000) (play :wait #t))
- (scale-to .1 (choose-fd))
- (scale-by 2.0 (choose-fd))
- (save-controls)
- (set! (amp-control) .5)
- (test-panel amp-control 'amp-control)
- (restore-controls)
- (status-report "hi")
-
- (without-errors
- (begin
- (let ((cfd (choose-fd)))
- (safe-make-selection cfd)
- (src-selection .5)
- (undo 1 cfd))
- (let ((cfd (choose-fd)))
- (safe-make-selection cfd)
- (src-selection -1.5)
- (undo 1 cfd))
- (let ((cfd (choose-fd)))
- (safe-make-selection cfd)
- (scale-selection-by .5)
- (undo 1 cfd))
- (let ((cfd (choose-fd)))
- (safe-make-selection cfd)
- (env-selection '(0 0 1 1 2 0))
- (undo 1 cfd))
- (let ((cfd (choose-fd)))
- (safe-make-selection cfd)
- (scale-selection-to .5)
- (reverse-selection)
- (undo 2 cfd))
- (if (> (length (regions)) 2) (forget-region ((regions) 2)))))
- (for-each revert-sound open-files)
-
- (without-errors
- (let ((cfd (car open-files)))
- (set! (sync cfd) 1)
- (if (pair? (cdr open-files)) (set! (sync (cadr open-files)) 1))
+ (delete-marks curfd)
+ (if (> (duration curfd) 0.0)
+ (set! (x-bounds curfd) (list 0.0 (min (duration curfd) 0.1))))
+ (set! (y-bounds curfd) '(-1.0 1.0))
+ (if (or (> (length (marks curfd 0)) 0)
+ (not (= new-marks (+ old-marks 3))))
+ (snd-display ";delete marks: ~A ~A?" new-marks old-marks)))))
+ ))
+
+ (revert-sound)
+ (let-temporarily ((*selection-creates-region* #t))
+ (let ((reg (select-all)))
+ (without-errors
+ (if (and (region? reg)
+ (selection?))
+ (let ((r1 (region-rms (car (regions))))
+ (r2 (selection-rms)))
+ (if (fneq r1 r2)
+ (snd-display ";region rms: ~A?" r1)))))))
+
+ (without-errors (if (region? (cadr (regions))) (play (cadr (regions)) :wait #t)))
+ (without-errors (mix-region (car (regions))))
+ (if (< (framples) 100000) (play :wait #t))
+ (scale-to .1 (choose-fd))
+ (scale-by 2.0 (choose-fd))
+ (save-controls)
+ (set! (amp-control) .5)
+ (test-panel amp-control 'amp-control)
+ (restore-controls)
+ (status-report "hi")
+
+ (without-errors
+ (begin
+ (let ((cfd (choose-fd)))
(safe-make-selection cfd)
(src-selection .5)
- (undo 1 cfd)
+ (undo 1 cfd))
+ (let ((cfd (choose-fd)))
(safe-make-selection cfd)
(src-selection -1.5)
- (undo 1 cfd)
- (safe-make-selection cfd)
- (env-selection '(0 0 1 1 2 0))
- (undo 1 cfd)
- (safe-make-selection cfd)
- (reverse-selection)
- (undo 1 cfd)
+ (undo 1 cfd))
+ (let ((cfd (choose-fd)))
(safe-make-selection cfd)
- (filter-selection '(0 0 .1 1 1 0) 40)
- (undo 1 cfd)
- (safe-make-selection cfd)
- (convolve-selection-with "oboe.snd")
- (undo 1 cfd)
+ (scale-selection-by .5)
+ (undo 1 cfd))
+ (let ((cfd (choose-fd)))
(safe-make-selection cfd)
- (smooth-selection)
- (undo 1 cfd)
+ (env-selection '(0 0 1 1 2 0))
+ (undo 1 cfd))
+ (let ((cfd (choose-fd)))
(safe-make-selection cfd)
- (scale-selection-by .5)
- (undo 1 cfd)
(scale-selection-to .5)
(reverse-selection)
- (undo 2)
- (src-selection '(0 .5 1 1))
- (undo)
- (revert-sound cfd)
- (if (pair? (cdr open-files)) (revert-sound (cadr open-files)))))
+ (undo 2 cfd))
+ (if (> (length (regions)) 2) (forget-region ((regions) 2)))))
+ (for-each revert-sound open-files)
+
+ (without-errors
+ (let ((cfd (car open-files)))
+ (set! (sync cfd) 1)
+ (if (pair? (cdr open-files)) (set! (sync (cadr open-files)) 1))
+ (safe-make-selection cfd)
+ (src-selection .5)
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (src-selection -1.5)
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (env-selection '(0 0 1 1 2 0))
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (reverse-selection)
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (filter-selection '(0 0 .1 1 1 0) 40)
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (convolve-selection-with "oboe.snd")
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (smooth-selection)
+ (undo 1 cfd)
+ (safe-make-selection cfd)
+ (scale-selection-by .5)
+ (undo 1 cfd)
+ (scale-selection-to .5)
+ (reverse-selection)
+ (undo 2)
+ (src-selection '(0 .5 1 1))
+ (undo)
+ (revert-sound cfd)
+ (if (pair? (cdr open-files)) (revert-sound (cadr open-files)))))
+
+ (when (> 10000 (framples) 1)
+ (make-region 0 (framples))
+ (convolve-selection-with "fyow.snd" .5)
+ (play :wait #t)
+ (convolve-with "fyow.snd" .25))
+ (insert-sound "oboe.snd")
+ (set! (hook-functions graph-hook) ())
+ (set! (hook-functions after-transform-hook) ())
+ (for-each revert-sound open-files)
+
+ (let ((ind (choose-fd)))
+ (select-sound ind)
+ (for-each
+ (lambda (func func1)
+ (pad-channel 0 100 ind 0)
+ (func 0)
+ (pad-channel 0 100 ind 0)
+ (func1 0)
+ (revert-sound ind)
+ (if (> (chans ind) 1)
+ (begin
+ (pad-channel 0 100 ind 1)
+ (func 0)
+ (pad-channel 0 100 ind 1)
+ (func1 0)
+ (revert-sound ind)))
+ (delete-samples 0 1000 ind 0)
+ (func (* 2 (framples ind 0)))
+ (delete-samples 0 10000 ind 0)
+ (func1 (* 2 (framples ind 0)))
+ (revert-sound ind)
+ (if (> (chans ind) 1)
+ (begin
+ (delete-samples 0 1000 ind 1)
+ (func (* 2 (framples ind 1)))
+ (delete-samples 0 10000 ind 1)
+ (func1 (* 2 (framples ind 1)))
+ (revert-sound ind))))
+ (list (lambda (beg) (insert-sound "2a.snd" beg))
+ (lambda (beg) (reverse-sound))
+ (lambda (beg) (if (< (framples ind) 10000) (convolve-with "2a.snd" 0.5) (scale-by 2.0)))
+ (lambda (beg) (env-sound '(0 0 1 1 2 0)))
+ (lambda (beg) (smooth-sound)))
+ (list (lambda (beg) (insert-sound "4a.snd" beg))
+ (lambda (beg) (reverse-sound))
+ (lambda (beg) (src-sound 2.0))
+ (lambda (beg) (env-sound '(0 0 1 1)))
+ (lambda (beg) (insert-silence beg 100)))))
+
+ (let ((ind (open-sound "z.snd")))
+ (if (not (= (framples ind) 0)) (snd-display ";framples z.snd ~A" (framples ind)))
+ (if (samples) (snd-display ";samples of empty file (z): ~A" (samples)))
+ (if (channel->float-vector) (snd-display ";channel->float-vector of empty file (z): ~A" (channel->float-vector)))
+ (if (fneq (maxamp ind) 0.0) (snd-display ";maxamp z.snd ~A" (maxamp ind)))
+ (if (fneq (sample 100 ind) 0.0) (snd-display ";sample 100 z.snd ~A" (sample 100 ind)))
+ (scale-by 2.0)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";scale z: ~A" (edit-position ind 0)))
+ (env-sound '(0 0 1 1))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";env z: ~A" (edit-position ind 0)))
+ (smooth-sound)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";smooth z: ~A" (edit-position ind 0)))
+ (reverse-sound)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";reverse z: ~A" (edit-position ind 0)))
+ (src-sound 2.0)
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";src z: ~A" (edit-position ind 0)))
+ (insert-sound "z.snd")
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";insert z: ~A" (edit-position ind 0)))
+ (mix "z.snd")
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";mix z: ~A" (edit-position ind 0)))
+ (filter-sound (make-one-zero :a0 2.0 :a1 0.0))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";filter z: ~A" (edit-position ind 0)))
+ (if (not (= (mus-sound-duration "z.snd") 0.0)) (snd-display ";duration z.snd: ~A" (mus-sound-duration "z.snd")))
+ (catch 'IO-error
+ (lambda () (convolve-with "z.snd" 1.0))
+ (lambda args args))
+ (if (not (= (edit-position ind 0) 0)) (snd-display ";convolve z: ~A" (edit-position ind 0)))
+ (let ((matches (count-matches (lambda (y) (> y .1)))))
+ (if (and (integer? matches) (> matches 0))
+ (snd-display ";count z: ~A" matches)))
+ (let* ((reader (make-sampler 0))
+ (val (next-sample reader))
+ (str (format #f "~A" reader)))
+ (if (fneq val 0.0) (snd-display ";sampler z.snd: ~A" val))
+ (if (not (string? str)) (snd-display ";z.snd reader: ~A" str)))
+ (if (not (equal? (cursor-position) '(0 0))) (snd-display ";cursor-position z: ~A" (cursor-position)))
+ (if (not (= (cursor) 0)) (snd-display ";cursor z: ~A" (cursor)))
+ (let ((outer (make-player ind 0)))
+ (let ((pl (make-player ind 0)))
+ (add-player pl)
+ (start-playing 1 22050 #f))
+ (revert-sound ind)
+ (set! (transform-graph? ind 0) #t)
+ (hook-push lisp-graph-hook display-energy)
+ (set! (x-bounds) (list 0.0 .01))
+ (set! (sample 0) 0.5)
+ (set! (x-bounds) (list 0.0 .001))
+ (close-sound ind)
+ (let ((tag (catch #t (lambda () (add-player outer)) (lambda args (car args)))))
+ (if (not (eq? tag 'no-such-player))
+ (snd-display ";dangling player: ~A" tag)))))
+ (if (channel-amp-envs "z.snd" 0 100)
+ (snd-display ";channel-amp-envs of empty file: ~A" (channel-amp-envs "z.snd" 0 100)))
+
+ (let ((zz (view-sound "z.snd")))
+ (select-sound zz)
+ (mix "4.aiff")
+ (add-mark 0)
+ (add-mark 1200)
+ (delete-marks)
+ (revert-sound zz)
- (if (and (> (framples) 1)
- (< (framples) 10000))
+ (let ((editctr (edit-position zz))
+ (old-selection-choice *selection-creates-region*))
+ (set! *selection-creates-region* #t)
+ (if (not (= (edit-position) 0)) (snd-display ";revert-sound edit-position: ~A" (edit-position)))
+ (as-one-edit
+ (lambda ()
+ (mix s8-snd 24000)
+ (let ((reg (select-all)))
+ (if (selection?)
+ (begin
+ (filter-selection '(0 0 .2 1 .5 0 1 0) 40)
+ (delete-selection)
+ (mix-region reg))))))
+ (if (not (= (edit-position) 1)) (snd-display ";as-one-edit mix zz: ~A -> ~A" editctr (edit-position)))
+ (set! *selection-creates-region* old-selection-choice))
+ (close-sound zz))
+ (let ((s8 (view-sound s8-snd)))
+ (select-sound s8)
+ (if (= (channels s8) 8)
(begin
- (make-region 0 (framples))
- (convolve-selection-with "fyow.snd" .5)
- (play :wait #t)))
- (if (and (> (framples) 1)
- (< (framples) 10000))
- (convolve-with "fyow.snd" .25))
- (insert-sound "oboe.snd")
- (set! (hook-functions graph-hook) ())
- (set! (hook-functions after-transform-hook) ())
- (for-each revert-sound open-files)
-
- (let ((ind (choose-fd)))
- (select-sound ind)
- (for-each
- (lambda (func func1)
- (pad-channel 0 100 ind 0)
- (func 0)
- (pad-channel 0 100 ind 0)
- (func1 0)
- (revert-sound ind)
- (if (> (chans ind) 1)
- (begin
- (pad-channel 0 100 ind 1)
- (func 0)
- (pad-channel 0 100 ind 1)
- (func1 0)
- (revert-sound ind)))
- (delete-samples 0 1000 ind 0)
- (func (* 2 (framples ind 0)))
- (delete-samples 0 10000 ind 0)
- (func1 (* 2 (framples ind 0)))
- (revert-sound ind)
- (if (> (chans ind) 1)
- (begin
- (delete-samples 0 1000 ind 1)
- (func (* 2 (framples ind 1)))
- (delete-samples 0 10000 ind 1)
- (func1 (* 2 (framples ind 1)))
- (revert-sound ind))))
- (list (lambda (beg) (insert-sound "2a.snd" beg))
- (lambda (beg) (reverse-sound))
- (lambda (beg) (if (< (framples ind) 10000) (convolve-with "2a.snd" 0.5) (scale-by 2.0)))
- (lambda (beg) (env-sound '(0 0 1 1 2 0)))
- (lambda (beg) (smooth-sound)))
- (list (lambda (beg) (insert-sound "4a.snd" beg))
- (lambda (beg) (reverse-sound))
- (lambda (beg) (src-sound 2.0))
- (lambda (beg) (env-sound '(0 0 1 1)))
- (lambda (beg) (insert-silence beg 100)))))
-
- (let ((ind (open-sound "z.snd")))
- (if (not (= (framples ind) 0)) (snd-display ";framples z.snd ~A" (framples ind)))
- (if (samples) (snd-display ";samples of empty file (z): ~A" (samples)))
- (if (channel->float-vector) (snd-display ";channel->float-vector of empty file (z): ~A" (channel->float-vector)))
- (if (fneq (maxamp ind) 0.0) (snd-display ";maxamp z.snd ~A" (maxamp ind)))
- (if (fneq (sample 100 ind) 0.0) (snd-display ";sample 100 z.snd ~A" (sample 100 ind)))
- (scale-by 2.0)
- (if (not (= (edit-position ind 0) 0)) (snd-display ";scale z: ~A" (edit-position ind 0)))
- (env-sound '(0 0 1 1))
- (if (not (= (edit-position ind 0) 0)) (snd-display ";env z: ~A" (edit-position ind 0)))
- (smooth-sound)
- (if (not (= (edit-position ind 0) 0)) (snd-display ";smooth z: ~A" (edit-position ind 0)))
- (reverse-sound)
- (if (not (= (edit-position ind 0) 0)) (snd-display ";reverse z: ~A" (edit-position ind 0)))
- (src-sound 2.0)
- (if (not (= (edit-position ind 0) 0)) (snd-display ";src z: ~A" (edit-position ind 0)))
- (insert-sound "z.snd")
- (if (not (= (edit-position ind 0) 0)) (snd-display ";insert z: ~A" (edit-position ind 0)))
- (mix "z.snd")
- (if (not (= (edit-position ind 0) 0)) (snd-display ";mix z: ~A" (edit-position ind 0)))
- (filter-sound (make-one-zero :a0 2.0 :a1 0.0))
- (if (not (= (edit-position ind 0) 0)) (snd-display ";filter z: ~A" (edit-position ind 0)))
- (if (not (= (mus-sound-duration "z.snd") 0.0)) (snd-display ";duration z.snd: ~A" (mus-sound-duration "z.snd")))
- (catch 'IO-error
- (lambda () (convolve-with "z.snd" 1.0))
- (lambda args args))
- (if (not (= (edit-position ind 0) 0)) (snd-display ";convolve z: ~A" (edit-position ind 0)))
- (let ((matches (count-matches (lambda (y) (> y .1)))))
- (if (and (number? matches) (> matches 0))
- (snd-display ";count z: ~A" matches)))
- (let* ((reader (make-sampler 0))
- (val (next-sample reader))
- (str (format #f "~A" reader)))
- (if (fneq val 0.0) (snd-display ";sampler z.snd: ~A" val))
- (if (not (string? str)) (snd-display ";z.snd reader: ~A" str)))
- (if (not (equal? (cursor-position) (list 0 0))) (snd-display ";cursor-position z: ~A" (cursor-position)))
- (if (not (= (cursor) 0)) (snd-display ";cursor z: ~A" (cursor)))
- (let ((outer (make-player ind 0)))
- (let ((pl (make-player ind 0)))
- (add-player pl)
- (start-playing 1 22050 #f))
- (revert-sound ind)
- (set! (transform-graph? ind 0) #t)
- (hook-push lisp-graph-hook display-energy)
- (set! (x-bounds) (list 0.0 .01))
- (set! (sample 0) 0.5)
- (set! (x-bounds) (list 0.0 .001))
- (close-sound ind)
- (let ((tag (catch #t (lambda () (add-player outer)) (lambda args (car args)))))
- (if (not (eq? tag 'no-such-player))
- (snd-display ";dangling player: ~A" tag)))))
- (if (channel-amp-envs "z.snd" 0 100)
- (snd-display ";channel-amp-envs of empty file: ~A" (channel-amp-envs "z.snd" 0 100)))
-
- (let ((zz (view-sound "z.snd")))
- (select-sound zz)
- (mix "4.aiff")
- (add-mark 0)
- (add-mark 1200)
- (delete-marks)
- (revert-sound zz)
-
- (let ((editctr (edit-position zz))
- (old-selection-choice *selection-creates-region*))
- (set! *selection-creates-region* #t)
- (if (not (= (edit-position) 0)) (snd-display ";revert-sound edit-position: ~A" (edit-position)))
- (as-one-edit
- (lambda ()
- (mix s8-snd 24000)
- (let ((reg (select-all)))
- (if (selection?)
- (begin
- (filter-selection '(0 0 .2 1 .5 0 1 0) 40)
- (delete-selection)
- (mix-region reg))))))
- (if (not (= (edit-position) 1)) (snd-display ";as-one-edit mix zz: ~A -> ~A" editctr (edit-position)))
- (set! *selection-creates-region* old-selection-choice))
- (close-sound zz))
- (let ((s8 (view-sound s8-snd)))
- (select-sound s8)
- (if (= (channels s8) 8)
- (begin
- (select-channel 5)
- (if (not (and (number? (selected-channel))
- (= (selected-channel) 5)))
- (snd-display ";select-channel: ~A?" (selected-channel)))))
- (let ((editctr (edit-position)))
- (as-one-edit
- (lambda ()
- (let ((reg (select-all)))
- (delete-selection)
- (mix "4.aiff")
- (set! (sync) 1)
- (mix "oboe.snd" 60000)
- (scale-by .1)
- (set! (sync) 1)
- (if (> (channels s8) 3)
- (select-channel 3))
- (if (region? reg)
- (insert-region reg 80000)))))
- (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit s8: ~A -> ~A" editctr (edit-position))))
- (revert-sound s8)
- (close-sound s8))
-
- (let ((cfd (choose-fd)))
- (if (> (chans cfd) 1)
- (let ((uval (random 3)))
- (set! (channel-style cfd) uval)
- (if (not (= uval (channel-style cfd))) (snd-display ";channel-style: ~A ~A?" uval (channel-style cfd)))))
- (when (< (framples cfd) 200000)
- (src-sound 2.5 1.0 cfd)
- (src-sound -2.5 1.0 cfd)
- (src-sound .5 1.0 cfd)
- (revert-sound cfd)
- (src-sound -.5 1.0 cfd)
- (src-sound '(0 .5 1 1.5) 1.0 cfd)
- (if (> (framples cfd) 0) (src-sound (make-env '(0 .5 1 1.5) :length (framples cfd)) 1.0 cfd))
- (revert-sound cfd)
- (filter-sound '(0 1 .2 0 .5 1 1 0) 20 cfd)
- (filter-sound '(0 0 .1 0 .11 1 .12 0 1 0) 2048 cfd)
- (env-sound '(0 0 .5 1 1 0) 0 (framples cfd) 1.0 cfd)
- (insert-sample 1200 .1 cfd)
- (if (fneq (sample 1200 cfd) .1) (snd-display ";insert-sample(looped): ~A?" (sample 1200 cfd))))
- (revert-sound cfd))
-
- (let ((cfd (open-sound "obtest.snd")))
- (select-sound cfd)
- (let ((cfd2 (open-sound "pistol.snd")))
- (select-sound cfd2)
- ;; now run apply a few times
- (set! (amp-control) .5)
- (set! (speed-control) 2.0)
- (test-panel speed-control 'speed-control)
- (apply-controls)
- (if (< (framples) 100000) (play :wait #t))
-
- (if (fneq (reverb-control-decay cfd) *reverb-control-decay*)
- (snd-display ";reverb-control-decay local: ~A, global: ~A" (reverb-control-decay cfd) *reverb-control-decay*))
- (set! (reverb-control?) #t)
- (set! (reverb-control-scale) .2)
- (test-panel reverb-control-scale 'reverb-control-scale)
- (test-panel reverb-control-length 'reverb-control-length)
- (test-panel reverb-control-lowpass 'reverb-control-lowpass)
- (test-panel reverb-control-feedback 'reverb-control-feedback)
- (apply-controls)
- (if (< (framples) 100000) (play :wait #t))
- (set! (contrast-control?) #t)
- (set! (contrast-control) .5)
- (test-panel contrast-control 'contrast-control)
- (test-panel contrast-control-amp 'contrast-control-amp)
- (apply-controls)
-; (if (< (framples) 100000) (play :wait #t))
- (set! (expand-control?) #t)
- (set! (expand-control) 2.5)
- (test-panel expand-control 'expand-control)
- (test-panel expand-control-length 'expand-control-length)
- (test-panel expand-control-hop 'expand-control-hop)
- (test-panel expand-control-ramp 'expand-control-ramp)
- (apply-controls)
-; (if (< (framples) 100000) (play :wait #t))
- (set! (filter-control?) #t)
- (set! *filter-control-order* 40)
- (test-panel filter-control-order 'filter-control-order)
- (set! (filter-control-envelope) '(0 0 .1 1 .2 0 1 0))
- (filter-control-envelope)
- (apply-controls)
-; (if (< (framples) 100000) (play :wait #t))
- (set! (amp-control) 1.5)
- (test-panel amp-control 'amp-control)
- (apply-controls)
-; (if (< (framples) 100000) (play :wait #t))
- (swap-channels cfd 0 cfd2 0)
- (set! (amp-control #t) .75)
- (test-panel amp-control 'amp-control)
- (if (> (abs (- (amp-control cfd2) .75)) .05) (snd-display ";set-amp .75 #t -> ~A?" (amp-control cfd2)))
- (set! (contrast-control-amp #t) .75)
- (if (fneq (contrast-control-amp cfd2) .75) (snd-display ";set-contrast-control-amp .75 #t -> ~A?" (contrast-control-amp cfd2)))
- (set! (contrast-control-bounds cfd2) (list 2.0 3.0))
- (if (not (feql (contrast-control-bounds cfd2) (list 2.0 3.0)))
- (snd-display ";cfd2 contrast-control-bounds: ~A" (contrast-control-bounds cfd2)))
- (set! (expand-control-length #t) .025)
- (if (fneq (expand-control-length cfd2) .025) (snd-display ";set-expand-control-length .025 #t -> ~A?" (expand-control-length cfd2)))
- (set! (expand-control-hop #t) .025)
- (if (fneq (expand-control-hop cfd2) .025) (snd-display ";set-expand-control-hop .025 #t -> ~A?" (expand-control-hop cfd2)))
- (set! (expand-control-jitter #t) .025)
- (if (fneq (expand-control-jitter cfd2) .025) (snd-display ";set-expand-control-jitter .025 #t -> ~A?" (expand-control-jitter cfd2)))
- (set! (expand-control-ramp #t) .025)
- (if (fneq (expand-control-ramp cfd2) .025) (snd-display ";set-expand-control-ramp .025 #t -> ~A?" (expand-control-ramp cfd2)))
- (let ((clone (clone-sound-as "/tmp/cloned.snd" cfd2)))
- (if (not (= (framples cfd2) (framples clone)))
- (snd-display ";clone framples: ~A ~A" (framples cfd2) (framples clone)))
- (close-sound clone))
- (delete-file "/tmp/cloned.snd")
- (mus-sound-forget "/tmp/cloned.snd")
- (close-sound cfd2)
- (close-sound cfd)))
- (hook-push (edit-hook) (lambda (hook) (set! (hook 'result) #f)))
+ (select-channel 5)
+ (if (not (eqv? (selected-channel) 5))
+ (snd-display ";select-channel: ~A?" (selected-channel)))))
(let ((editctr (edit-position)))
- (as-one-edit (lambda () (set! (sample 200) .2) (set! (sample 300) .3)))
- (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit: ~A -> ~A" editctr (edit-position)))
- (as-one-edit (lambda () #f))
- (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit nil: ~A -> ~A" editctr (edit-position))))
- (delete-sample 250)
- (hook-push (undo-hook) (lambda (hook) (set! (hook 'result) #f)))
- (undo)
- (delete-sample 250)
- (undo)
- (as-one-edit (lambda () (set! (sample 20) .2) (set! (sample 30) .3)))
- (undo 1)
- (as-one-edit (lambda () (set! (sample 2) .2) (as-one-edit (lambda () (set! (sample 3) .3)))))
- (undo 2)
- (set! (hook-functions (undo-hook)) ())
- (set! (hook-functions (edit-hook)) ())
- (hook-push snd-warning-hook
- (lambda (hook)
- (let ((msg (hook 'message)))
- (if (not (string=? msg "hiho")) (snd-display ";snd-warning-hook: ~A?" msg))
- (set! (hook 'result) #t))))
- (snd-warning "hiho")
- (set! (hook-functions snd-error-hook) ())
- (set! (hook-functions snd-warning-hook) ())
- (hook-push name-click-hook
- (lambda (hook)
- (set! (hook 'result) #t)))
- (redo 1)
- (set! (hook-functions name-click-hook) ())
- (set! (transform-graph?) #t)
- (test-channel transform-graph? 'transform-graph?)
- (test-channel time-graph? 'time-graph?)
- (test-channel lisp-graph? 'lisp-graph?)
- (test-channel framples 'framples)
- (test-channel cursor 'cursor)
- (test-channel cursor-size 'cursor-size)
- (test-channel cursor-style 'cursor-style)
- (test-channel tracking-cursor-style 'tracking-cursor-style)
- (test-channel left-sample 'left-sample)
- (test-channel right-sample 'right-sample)
- (test-channel squelch-update 'squelch-update)
- (test-channel x-zoom-slider 'x-zoom-slider)
- (test-channel y-zoom-slider 'y-zoom-slider)
- (test-channel x-position-slider 'x-position-slider)
- (test-channel y-position-slider 'y-position-slider)
- (test-channel edit-position 'edit-position)
- (test-channel maxamp 'maxamp)
- (test-channel edit-hook 'edit-hook)
- (test-channel after-edit-hook 'after-edit-hook)
- (test-channel undo-hook 'undo-hook)
- (if (<= tests 2)
- (set! *transform-type*
- (add-transform "histogram" "bins" 0.0 1.0
- (lambda (len fd)
- (let ((v (make-float-vector len))
- (steps (/ len 16))
- (step (/ 1.0 len)))
- (fill! v 0.0)
- (do ((i 0 (+ i 1)))
- ((= i len) v)
- (let ((bin (round (* 16.0 (abs (next-sample fd))))))
- (if (< bin steps)
- (float-vector-offset! (make-shared-vector v (list steps) bin) step)))))))))
- (set! (x-bounds) '(.1 .2))
- (set! *transform-type* fourier-transform)
- (set! (x-bounds) '(.1 .2))
- (hook-push lisp-graph-hook display-energy)
- (set! (hook-functions graph-hook) ())
- (if (= (channels) 2)
- (begin
- (hook-push graph-hook display-correlation)
- (set! (x-bounds) '(.1 .12))
- (set! (x-bounds) '(.1 .2))
- (hook-remove graph-hook display-correlation)))
- (set! (lisp-graph?) #f)
- (map-channel
- (let ((buffer (make-delay 128))
- (gen (make-moving-average 128))
- (current-sample 0)
- (chan-samples (framples)))
- (set! (mus-feedback gen) 1.0)
- (lambda (y)
- (let ((old-y (delay buffer y)))
- (set! current-sample (+ 1 current-sample))
- (and (> (moving-average gen (* y y)) .01)
- (if (not (= current-sample chan-samples))
- old-y
- ;; at end return trailing samples as long as it looks like sound
- (let ((temp-buffer (make-delay 128)))
- (do ((i 0 (+ i 1))
- (fy (delay buffer 0.0) (delay buffer 0.0)))
- ((= i 128)
- (mus-data temp-buffer))
- (delay temp-buffer (if (> (moving-average gen 0.0) .01) fy 0.0)))))))))
- 0 20)
-
- (let ((maxval1 (+ (maxamp) .01)))
- (if (not (every-sample? (lambda (y) (< y maxval1))))
- (let ((res (scan-channel (lambda (y) (>= y maxval1)))))
- (snd-display ";~A, every-sample: ~A ~A [~A: ~A]?" (short-file-name) maxval1 res (cursor) (sample (cursor)))
- (do ((i 0 (+ i 1)))
- ((= i (edit-position)))
- (snd-display ";~D: ~A ~A" i (maxamp #f 0 i) (edit-fragment i))))))
-
- (map-channel (echo .5 .75) 0 60000)
- (set! (hook-functions after-transform-hook) ())
- (set! (hook-functions lisp-graph-hook) ())
-
- (hook-push lisp-graph-hook
- (lambda (hook)
- (if (> (random 1.0) .5)
- (graph (float-vector 0 1 2))
- (graph (list (float-vector 0 1 2) (float-vector 3 2 0))))))
-
+ (as-one-edit
+ (lambda ()
+ (let ((reg (select-all)))
+ (delete-selection)
+ (mix "4.aiff")
+ (set! (sync) 1)
+ (mix "oboe.snd" 60000)
+ (scale-by .1)
+ (set! (sync) 1)
+ (if (> (channels s8) 3)
+ (select-channel 3))
+ (if (region? reg)
+ (insert-region reg 80000)))))
+ (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit s8: ~A -> ~A" editctr (edit-position))))
+ (revert-sound s8)
+ (close-sound s8))
+
+ (let ((cfd (choose-fd)))
+ (if (> (chans cfd) 1)
+ (let ((uval (random 3)))
+ (set! (channel-style cfd) uval)
+ (if (not (= uval (channel-style cfd))) (snd-display ";channel-style: ~A ~A?" uval (channel-style cfd)))))
+ (when (< (framples cfd) 200000)
+ (src-sound 2.5 1.0 cfd)
+ (src-sound -2.5 1.0 cfd)
+ (src-sound .5 1.0 cfd)
+ (revert-sound cfd)
+ (src-sound -.5 1.0 cfd)
+ (src-sound '(0 .5 1 1.5) 1.0 cfd)
+ (if (> (framples cfd) 0) (src-sound (make-env '(0 .5 1 1.5) :length (framples cfd)) 1.0 cfd))
+ (revert-sound cfd)
+ (filter-sound '(0 1 .2 0 .5 1 1 0) 20 cfd)
+ (filter-sound '(0 0 .1 0 .11 1 .12 0 1 0) 2048 cfd)
+ (env-sound '(0 0 .5 1 1 0) 0 (framples cfd) 1.0 cfd)
+ (insert-sample 1200 .1 cfd)
+ (if (fneq (sample 1200 cfd) .1) (snd-display ";insert-sample(looped): ~A?" (sample 1200 cfd))))
+ (revert-sound cfd))
+
+ (let ((cfd (open-sound "obtest.snd")))
+ (select-sound cfd)
+ (let ((cfd2 (open-sound "pistol.snd")))
+ (select-sound cfd2)
+ ;; now run apply a few times
+ (set! (amp-control) .5)
+ (set! (speed-control) 2.0)
+ (test-panel speed-control 'speed-control)
+ (apply-controls)
+ (if (< (framples) 100000) (play :wait #t))
+
+ (if (fneq (reverb-control-decay cfd) *reverb-control-decay*)
+ (snd-display ";reverb-control-decay local: ~A, global: ~A" (reverb-control-decay cfd) *reverb-control-decay*))
+ (set! (reverb-control?) #t)
+ (set! (reverb-control-scale) .2)
+ (test-panel reverb-control-scale 'reverb-control-scale)
+ (test-panel reverb-control-length 'reverb-control-length)
+ (test-panel reverb-control-lowpass 'reverb-control-lowpass)
+ (test-panel reverb-control-feedback 'reverb-control-feedback)
+ (apply-controls)
+ (if (< (framples) 100000) (play :wait #t))
+ (set! (contrast-control?) #t)
+ (set! (contrast-control) .5)
+ (test-panel contrast-control 'contrast-control)
+ (test-panel contrast-control-amp 'contrast-control-amp)
+ (apply-controls)
+ ; (if (< (framples) 100000) (play :wait #t))
+ (set! (expand-control?) #t)
+ (set! (expand-control) 2.5)
+ (test-panel expand-control 'expand-control)
+ (test-panel expand-control-length 'expand-control-length)
+ (test-panel expand-control-hop 'expand-control-hop)
+ (test-panel expand-control-ramp 'expand-control-ramp)
+ (apply-controls)
+ ; (if (< (framples) 100000) (play :wait #t))
+ (set! (filter-control?) #t)
+ (set! *filter-control-order* 40)
+ (test-panel filter-control-order 'filter-control-order)
+ (set! (filter-control-envelope) '(0 0 .1 1 .2 0 1 0))
+ (apply-controls)
+ ; (if (< (framples) 100000) (play :wait #t))
+ (set! (amp-control) 1.5)
+ (test-panel amp-control 'amp-control)
+ (apply-controls)
+ ; (if (< (framples) 100000) (play :wait #t))
+ (swap-channels cfd 0 cfd2 0)
+ (set! (amp-control #t) .75)
+ (test-panel amp-control 'amp-control)
+ (if (> (abs (- (amp-control cfd2) .75)) .05) (snd-display ";set-amp .75 #t -> ~A?" (amp-control cfd2)))
+ (set! (contrast-control-amp #t) .75)
+ (if (fneq (contrast-control-amp cfd2) .75) (snd-display ";set-contrast-control-amp .75 #t -> ~A?" (contrast-control-amp cfd2)))
+ (set! (contrast-control-bounds cfd2) (list 2.0 3.0))
+ (if (not (feql (contrast-control-bounds cfd2) '(2.0 3.0)))
+ (snd-display ";cfd2 contrast-control-bounds: ~A" (contrast-control-bounds cfd2)))
+ (set! (expand-control-length #t) .025)
+ (if (fneq (expand-control-length cfd2) .025) (snd-display ";set-expand-control-length .025 #t -> ~A?" (expand-control-length cfd2)))
+ (set! (expand-control-hop #t) .025)
+ (if (fneq (expand-control-hop cfd2) .025) (snd-display ";set-expand-control-hop .025 #t -> ~A?" (expand-control-hop cfd2)))
+ (set! (expand-control-jitter #t) .025)
+ (if (fneq (expand-control-jitter cfd2) .025) (snd-display ";set-expand-control-jitter .025 #t -> ~A?" (expand-control-jitter cfd2)))
+ (set! (expand-control-ramp #t) .025)
+ (if (fneq (expand-control-ramp cfd2) .025) (snd-display ";set-expand-control-ramp .025 #t -> ~A?" (expand-control-ramp cfd2)))
+ (let ((clone (clone-sound-as "/tmp/cloned.snd" cfd2)))
+ (if (not (= (framples cfd2) (framples clone)))
+ (snd-display ";clone framples: ~A ~A" (framples cfd2) (framples clone)))
+ (close-sound clone))
+ (delete-file "/tmp/cloned.snd")
+ (mus-sound-forget "/tmp/cloned.snd")
+ (close-sound cfd2)
+ (close-sound cfd)))
+ (hook-push (edit-hook) (lambda (hook) (set! (hook 'result) #f)))
+ (let ((editctr (edit-position)))
+ (as-one-edit (lambda () (set! (sample 200) .2) (set! (sample 300) .3)))
+ (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit: ~A -> ~A" editctr (edit-position)))
+ (as-one-edit (lambda () #f))
+ (if (not (= (edit-position) (+ 1 editctr))) (snd-display ";as-one-edit nil: ~A -> ~A" editctr (edit-position))))
+ (delete-sample 250)
+ (hook-push (undo-hook) (lambda (hook) (set! (hook 'result) #f)))
+ (undo)
+ (delete-sample 250)
+ (undo)
+ (as-one-edit (lambda () (set! (sample 20) .2) (set! (sample 30) .3)))
+ (undo 1)
+ (as-one-edit (lambda () (set! (sample 2) .2) (as-one-edit (lambda () (set! (sample 3) .3)))))
+ (undo 2)
+ (set! (hook-functions (undo-hook)) ())
+ (set! (hook-functions (edit-hook)) ())
+ (hook-push snd-warning-hook
+ (lambda (hook)
+ (let ((msg (hook 'message)))
+ (if (not (string=? msg "hiho")) (snd-display ";snd-warning-hook: ~A?" msg))
+ (set! (hook 'result) #t))))
+ (snd-warning "hiho")
+ (set! (hook-functions snd-error-hook) ())
+ (set! (hook-functions snd-warning-hook) ())
+ (hook-push name-click-hook
+ (lambda (hook)
+ (set! (hook 'result) #t)))
+ (redo 1)
+ (set! (hook-functions name-click-hook) ())
+ (set! (transform-graph?) #t)
+ (test-channel transform-graph? 'transform-graph?)
+ (test-channel time-graph? 'time-graph?)
+ (test-channel lisp-graph? 'lisp-graph?)
+ (test-channel framples 'framples)
+ (test-channel cursor 'cursor)
+ (test-channel cursor-size 'cursor-size)
+ (test-channel cursor-style 'cursor-style)
+ (test-channel tracking-cursor-style 'tracking-cursor-style)
+ (test-channel left-sample 'left-sample)
+ (test-channel right-sample 'right-sample)
+ (test-channel squelch-update 'squelch-update)
+ (test-channel x-zoom-slider 'x-zoom-slider)
+ (test-channel y-zoom-slider 'y-zoom-slider)
+ (test-channel x-position-slider 'x-position-slider)
+ (test-channel y-position-slider 'y-position-slider)
+ (test-channel edit-position 'edit-position)
+ (test-channel maxamp 'maxamp)
+ (test-channel edit-hook 'edit-hook)
+ (test-channel after-edit-hook 'after-edit-hook)
+ (test-channel undo-hook 'undo-hook)
+ (if (<= tests 2)
+ (set! *transform-type*
+ (add-transform "histogram" "bins" 0.0 1.0
+ (lambda (len fd)
+ (let ((v (make-float-vector len))
+ (steps (/ len 16))
+ (step (/ 1.0 len)))
+ (fill! v 0.0)
+ (do ((i 0 (+ i 1)))
+ ((= i len) v)
+ (let ((bin (round (* 16.0 (abs (next-sample fd))))))
+ (if (< bin steps)
+ (float-vector-offset! (make-shared-vector v (list steps) bin) step)))))))))
+ (set! (x-bounds) '(.1 .2))
+ (set! *transform-type* fourier-transform)
+ (set! (x-bounds) '(.1 .2))
+ (hook-push lisp-graph-hook display-energy)
+ (set! (hook-functions graph-hook) ())
+ (if (= (channels) 2)
+ (begin
+ (hook-push graph-hook display-correlation)
+ (set! (x-bounds) '(.1 .12))
+ (set! (x-bounds) '(.1 .2))
+ (hook-remove graph-hook display-correlation)))
+ (set! (lisp-graph?) #f)
+ (map-channel
+ (let ((buffer (make-delay 128))
+ (gen (make-moving-average 128))
+ (current-sample 0)
+ (chan-samples (framples)))
+ (set! (mus-feedback gen) 1.0)
+ (lambda (y)
+ (let ((old-y (delay buffer y)))
+ (set! current-sample (+ 1 current-sample))
+ (and (> (moving-average gen (* y y)) .01)
+ (if (not (= current-sample chan-samples))
+ old-y
+ ;; at end return trailing samples as long as it looks like sound
+ (let ((temp-buffer (make-delay 128)))
+ (do ((i 0 (+ i 1))
+ (fy (delay buffer 0.0) (delay buffer 0.0)))
+ ((= i 128)
+ (mus-data temp-buffer))
+ (delay temp-buffer (if (> (moving-average gen 0.0) .01) fy 0.0)))))))))
+ 0 20)
+
+ (let ((maxval1 (+ (maxamp) .01)))
+ (if (not (every-sample? (lambda (y) (< y maxval1))))
+ (let ((res (scan-channel (lambda (y) (>= y maxval1)))))
+ (snd-display ";~A, every-sample: ~A ~A [~A: ~A]?" (short-file-name) maxval1 res (cursor) (sample (cursor)))
+ (do ((i 0 (+ i 1)))
+ ((= i (edit-position)))
+ (snd-display ";~D: ~A ~A" i (maxamp #f 0 i) (edit-fragment i))))))
+
+ (map-channel (echo .5 .75) 0 60000)
+ (set! (hook-functions after-transform-hook) ())
+ (set! (hook-functions lisp-graph-hook) ())
+
+ (hook-push lisp-graph-hook
+ (lambda (hook)
+ (if (> (random 1.0) .5)
+ (graph (float-vector 0 1 2))
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 0))))))
+
+ (for-each
+ (lambda (snd)
+ (set! (sync snd) (random 3))
+ (update-lisp-graph snd))
+ (sounds))
+ (hook-push graph-hook superimpose-ffts)
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
(for-each
(lambda (snd)
- (set! (sync snd) (random 3))
- (update-lisp-graph snd))
- (sounds))
- (hook-push graph-hook superimpose-ffts)
- (do ((i 0 (+ i 1)))
- ((= i 10))
- (for-each
- (lambda (snd)
- (if (> (framples snd) 0)
- (let* ((dur (floor (/ (framples snd) (srate snd))))
- (start (max 0.0 (min (- dur .1) (random dur)))))
- (if (> dur 0.0)
- (set! (x-bounds snd 0) (list start (min (+ start .1) dur))))))
- (update-time-graph snd)
- (update-lisp-graph snd)
- (update-transform-graph snd))
- (sounds)))
- (set! (hook-functions graph-hook) ())
- (set! (hook-functions lisp-graph-hook) ())
-
- ;; new variable settings
- (letrec ((reset-vars
- (lambda (lst)
- (when (pair? lst)
- (let* ((name ((car lst) 0))
- (index (and ((car lst) 2) (choose-fd)))
- (getfnc ((car lst) 1))
- (setfnc (lambda (val snd) (set! (getfnc snd) val)))
- (setfnc-1 (lambda (val) (set! (getfnc) val)))
- (minval ((car lst) 3))
- (maxval ((car lst) 4)))
- (cond (index (setfnc (or (not minval)
- (if (rational? minval)
- (if (eq? name #t)
- (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2)))))
- (+ minval (floor (random (- maxval minval)))))
- (+ minval (random (- maxval minval)))))
- index))
- ((not minval)
- (setfnc-1 #t))
- ((not (rational? minval))
- (setfnc-1 (+ minval (random (- maxval minval)))))
- ((eq? name #t)
- (setfnc-1 (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2)))))))
- (else
- (setfnc-1 (+ minval (floor (random (- maxval minval)))))))
- (reset-vars (cdr lst)))))))
- (reset-vars
- (list
- (list 'amp-control amp-control #t .1 1.0)
+ (if (> (framples snd) 0)
+ (let* ((dur (floor (/ (framples snd) (srate snd))))
+ (start (max 0.0 (min (- dur .1) (random dur)))))
+ (if (> dur 0.0)
+ (set! (x-bounds snd 0) (list start (min (+ start .1) dur))))))
+ (update-time-graph snd)
+ (update-lisp-graph snd)
+ (update-transform-graph snd))
+ (sounds)))
+ (set! (hook-functions graph-hook) ())
+ (set! (hook-functions lisp-graph-hook) ())
+
+ ;; new variable settings
+ (letrec ((reset-vars
+ (lambda (lst)
+ (when (pair? lst)
+ (let* ((name ((car lst) 0))
+ (index (and ((car lst) 2) (choose-fd)))
+ (getfnc ((car lst) 1))
+ (setfnc (lambda (val snd) (set! (getfnc snd) val)))
+ (setfnc-1 (lambda (val) (set! (getfnc) val)))
+ (minval ((car lst) 3))
+ (maxval ((car lst) 4)))
+ (cond (index (setfnc (or (not minval)
+ (if (rational? minval)
+ (if (eq? name #t)
+ (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2)))))
+ (+ minval (floor (random (- maxval minval)))))
+ (+ minval (random (- maxval minval)))))
+ index))
+ ((not minval)
+ (setfnc-1 #t))
+ ((not (rational? minval))
+ (setfnc-1 (+ minval (random (- maxval minval)))))
+ ((eq? name #t)
+ (setfnc-1 (floor (expt 2 (min 31 (ceiling (log (+ minval (floor (random (- maxval minval)))) 2)))))))
+ (else
+ (setfnc-1 (+ minval (floor (random (- maxval minval)))))))
+ (reset-vars (cdr lst)))))))
+ (reset-vars
+ (list
+ (list 'amp-control amp-control #t .1 1.0)
;(list 'ask-before-overwrite ask-before-overwrite #f #f #t)
- (list 'auto-resize auto-resize #f #f #t)
- (list 'auto-update auto-update #f #f #t)
- (list 'channel-style channel-style #f 0 2)
- (list 'color-cutoff color-cutoff #f 0.0 0.2)
- (list 'color-inverted color-inverted #f #f #t)
- (list 'color-scale color-scale #f 0.1 1000.0)
- (list 'contrast-control contrast-control #t 0.0 1.0)
- (list 'contrast-control-amp contrast-control-amp #t 0.0 1.0)
- (list 'contrast-control? contrast-control? #t #f #t)
- (list 'auto-update-interval auto-update-interval #f 60.0 120.0)
- (list 'cursor-update-interval cursor-update-interval #f 0.05 .1)
- (list 'cursor-location-offset cursor-location-offset #f 0 1024)
- (list 'with-tracking-cursor with-tracking-cursor #f #f #t)
- (list 'cursor-size cursor-size #f 15 25)
- (list 'cursor-style cursor-style #f cursor-cross cursor-line)
- (list 'tracking-cursor-style tracking-cursor-style #f cursor-line cursor-cross)
- (list 'clipping clipping #f #f #t)
+ (list 'auto-resize auto-resize #f #f #t)
+ (list 'auto-update auto-update #f #f #t)
+ (list 'channel-style channel-style #f 0 2)
+ (list 'color-cutoff color-cutoff #f 0.0 0.2)
+ (list 'color-inverted color-inverted #f #f #t)
+ (list 'color-scale color-scale #f 0.1 1000.0)
+ (list 'contrast-control contrast-control #t 0.0 1.0)
+ (list 'contrast-control-amp contrast-control-amp #t 0.0 1.0)
+ (list 'contrast-control? contrast-control? #t #f #t)
+ (list 'auto-update-interval auto-update-interval #f 60.0 120.0)
+ (list 'cursor-update-interval cursor-update-interval #f 0.05 .1)
+ (list 'cursor-location-offset cursor-location-offset #f 0 1024)
+ (list 'with-tracking-cursor with-tracking-cursor #f #f #t)
+ (list 'cursor-size cursor-size #f 15 25)
+ (list 'cursor-style cursor-style #f cursor-cross cursor-line)
+ (list 'tracking-cursor-style tracking-cursor-style #f cursor-line cursor-cross)
+ (list 'clipping clipping #f #f #t)
;(list 'default-output-chans default-output-chans #f 1 8)
;(list 'default-output-sample-type default-output-sample-type #f 1 12)
;(list 'default-output-srate default-output-srate #f 22050 44100)
;(list 'default-output-header-type default-output-header-type #f 0 2)
- (list 'dot-size dot-size #f 1 10)
- (list 'enved-base enved-base #f 0.01 100.0)
- (list 'enved-clip? enved-clip? #f #f #t)
- (list 'enved-in-dB enved-in-dB #f #f #t)
- (list 'enved-style enved-style #f envelope-linear envelope-exponential)
- (list 'enved-power enved-power #f 3.0 3.5)
- (list 'enved-target enved-target #f 0 2)
- (list 'enved-wave? enved-wave? #f #f #t)
- (list 'expand-control expand-control #t 0.1 5.0)
- (list 'expand-control-hop expand-control-hop #t 0.01 0.5)
- (list 'expand-control-jitter expand-control-jitter #t 0.01 0.5)
- (list 'expand-control-length expand-control-length #t 0.1 0.25)
- (list 'expand-control-ramp expand-control-ramp #t 0.1 0.4)
- (list 'expand-control? expand-control? #t #f #t)
- (list 'fft-window-alpha fft-window-alpha #f 0.0 1.0)
- (list 'fft-window-beta fft-window-beta #f 0.0 1.0)
- (list 'fft-log-frequency fft-log-frequency #f #f #t)
- (list 'fft-log-magnitude fft-log-magnitude #f #f #t)
- (list 'fft-with-phases fft-with-phases #f #f #t)
- (list 'transform-size transform-size #f 16 (if (<= tests 10) 4096 128))
- (list 'transform-graph-type transform-graph-type #f graph-once graph-as-spectrogram)
- (list 'fft-window fft-window #f 0 dolph-chebyshev-window)
- (list 'transform-graph? transform-graph? #t #f #t)
- (list 'filter-control-in-dB filter-control-in-dB #t #f #t)
- (list 'filter-control-in-hz filter-control-in-hz #t #f #t)
- (list 'filter-control-order filter-control-order #t 2 (if (<= tests 10) 400 40))
- (list 'filter-control? filter-control? #t #f #t)
-; (list 'graph-cursor graph-cursor #f 0 35)
- (list 'time-graph-style time-graph-style #f 0 4)
- (list 'lisp-graph-style lisp-graph-style #f 0 4)
- (list 'transform-graph-style transform-graph-style #f 0 4)
- (list 'graphs-horizontal graphs-horizontal #f #f #t)
- (list 'max-transform-peaks max-transform-peaks #f 1 100)
- (list 'max-regions max-regions #f 1 32)
- (list 'min-dB min-dB #f -120.0 -30.0)
- (list 'log-freq-start log-freq-start #f 50.0 5.0)
- (list 'selection-creates-region selection-creates-region #f #f #t)
- (list 'transform-normalization transform-normalization #f dont-normalize normalize-globally)
- (list 'play-arrow-size play-arrow-size #f 2 32)
- (list 'print-length print-length #f 2 32)
- (list 'region-graph-style region-graph-style #f graph-lines graph-lollipops)
- (list 'reverb-control-decay reverb-control-decay #f 0.0 2.0)
- (list 'reverb-control-feedback reverb-control-feedback #t 1.00 1.1)
- (list 'reverb-control-length reverb-control-length #t 1.0 2.0)
- (list 'reverb-control-lowpass reverb-control-lowpass #t 0.2 0.99)
- (list 'reverb-control-scale reverb-control-scale #t 0.0 0.2)
- (list 'reverb-control? reverb-control? #t #f #t)
- (list 'show-axes show-axes #f 0 2)
- (list 'show-transform-peaks show-transform-peaks #f #f #t)
- (list 'show-indices show-indices #f #f #t)
- (list 'show-marks show-marks #f #f #t)
- (list 'show-mix-waveforms show-mix-waveforms #t #f #t)
- (list 'show-selection-transform show-selection-transform #f #f #t)
- (list 'show-y-zero show-y-zero #f #f #t)
- (list 'show-grid show-grid #f #f #t)
- (list 'grid-density grid-density 1.0 0.1 4.0)
- (list 'show-sonogram-cursor show-sonogram-cursor #f #f #t)
- (list 'sinc-width sinc-width #f 4 100)
- (list 'spectrum-end spectrum-end #f 0.5 0.8)
- (list 'spectro-hop spectro-hop #f 2 20)
- (list 'spectrum-start spectrum-start #f 0.0 0.1)
- (list 'spectro-x-angle spectro-x-angle #f 0.0 90.0)
- (list 'spectro-x-scale spectro-x-scale #f 0.1 2.0)
- (list 'spectro-y-angle spectro-y-angle #f 0.0 90.0)
- (list 'spectro-y-scale spectro-y-scale #f 0.1 2.0)
- (list 'spectro-z-angle spectro-z-angle #f 0.0 359.0)
- (list 'spectro-z-scale spectro-z-scale #f 0.1 0.2)
- (list 'speed-control speed-control #t 0.1 5.0)
- (list 'speed-control-style speed-control-style #f 0 2)
- (list 'speed-control-tones speed-control-tones #f 2 100)
- (list 'sync sync #t 0 5)
- (list 'sync-style sync-style #f 0 3)
- (list 'with-verbose-cursor with-verbose-cursor #f #f #t)
- (list 'wavelet-type wavelet-type #f 0 10)
- (list 'time-graph? time-graph? #t #f #t)
- (list 'x-axis-style x-axis-style #f 0 2)
- (list 'beats-per-minute beats-per-minute #f 60.0 120.0)
- (list 'beats-per-measure beats-per-measure #f 4 120)
- (list 'zero-pad zero-pad #f 0 2)
- (list 'zoom-focus-style zoom-focus-style #f 0 3))))
-
- (if (not (equal? *transform-type* fourier-transform))
- (begin
- (set! (transform-graph? #t #t) #f)
- (set! *transform-size* (min *transform-size* 128))))
- )))
+ (list 'dot-size dot-size #f 1 10)
+ (list 'enved-base enved-base #f 0.01 100.0)
+ (list 'enved-clip? enved-clip? #f #f #t)
+ (list 'enved-in-dB enved-in-dB #f #f #t)
+ (list 'enved-style enved-style #f envelope-linear envelope-exponential)
+ (list 'enved-power enved-power #f 3.0 3.5)
+ (list 'enved-target enved-target #f 0 2)
+ (list 'enved-wave? enved-wave? #f #f #t)
+ (list 'expand-control expand-control #t 0.1 5.0)
+ (list 'expand-control-hop expand-control-hop #t 0.01 0.5)
+ (list 'expand-control-jitter expand-control-jitter #t 0.01 0.5)
+ (list 'expand-control-length expand-control-length #t 0.1 0.25)
+ (list 'expand-control-ramp expand-control-ramp #t 0.1 0.4)
+ (list 'expand-control? expand-control? #t #f #t)
+ (list 'fft-window-alpha fft-window-alpha #f 0.0 1.0)
+ (list 'fft-window-beta fft-window-beta #f 0.0 1.0)
+ (list 'fft-log-frequency fft-log-frequency #f #f #t)
+ (list 'fft-log-magnitude fft-log-magnitude #f #f #t)
+ (list 'fft-with-phases fft-with-phases #f #f #t)
+ (list 'transform-size transform-size #f 16 (if (<= tests 10) 4096 128))
+ (list 'transform-graph-type transform-graph-type #f graph-once graph-as-spectrogram)
+ (list 'fft-window fft-window #f 0 dolph-chebyshev-window)
+ (list 'transform-graph? transform-graph? #t #f #t)
+ (list 'filter-control-in-dB filter-control-in-dB #t #f #t)
+ (list 'filter-control-in-hz filter-control-in-hz #t #f #t)
+ (list 'filter-control-order filter-control-order #t 2 (if (<= tests 10) 400 40))
+ (list 'filter-control? filter-control? #t #f #t)
+ ; (list 'graph-cursor graph-cursor #f 0 35)
+ (list 'time-graph-style time-graph-style #f 0 4)
+ (list 'lisp-graph-style lisp-graph-style #f 0 4)
+ (list 'transform-graph-style transform-graph-style #f 0 4)
+ (list 'graphs-horizontal graphs-horizontal #f #f #t)
+ (list 'max-transform-peaks max-transform-peaks #f 1 100)
+ (list 'max-regions max-regions #f 1 32)
+ (list 'min-dB min-dB #f -120.0 -30.0)
+ (list 'log-freq-start log-freq-start #f 50.0 5.0)
+ (list 'selection-creates-region selection-creates-region #f #f #t)
+ (list 'transform-normalization transform-normalization #f dont-normalize normalize-globally)
+ (list 'play-arrow-size play-arrow-size #f 2 32)
+ (list 'print-length print-length #f 2 32)
+ (list 'region-graph-style region-graph-style #f graph-lines graph-lollipops)
+ (list 'reverb-control-decay reverb-control-decay #f 0.0 2.0)
+ (list 'reverb-control-feedback reverb-control-feedback #t 1.00 1.1)
+ (list 'reverb-control-length reverb-control-length #t 1.0 2.0)
+ (list 'reverb-control-lowpass reverb-control-lowpass #t 0.2 0.99)
+ (list 'reverb-control-scale reverb-control-scale #t 0.0 0.2)
+ (list 'reverb-control? reverb-control? #t #f #t)
+ (list 'show-axes show-axes #f 0 2)
+ (list 'show-transform-peaks show-transform-peaks #f #f #t)
+ (list 'show-indices show-indices #f #f #t)
+ (list 'show-marks show-marks #f #f #t)
+ (list 'show-mix-waveforms show-mix-waveforms #t #f #t)
+ (list 'show-selection-transform show-selection-transform #f #f #t)
+ (list 'show-y-zero show-y-zero #f #f #t)
+ (list 'show-grid show-grid #f #f #t)
+ (list 'grid-density grid-density 1.0 0.1 4.0)
+ (list 'show-sonogram-cursor show-sonogram-cursor #f #f #t)
+ (list 'sinc-width sinc-width #f 4 100)
+ (list 'spectrum-end spectrum-end #f 0.5 0.8)
+ (list 'spectro-hop spectro-hop #f 2 20)
+ (list 'spectrum-start spectrum-start #f 0.0 0.1)
+ (list 'spectro-x-angle spectro-x-angle #f 0.0 90.0)
+ (list 'spectro-x-scale spectro-x-scale #f 0.1 2.0)
+ (list 'spectro-y-angle spectro-y-angle #f 0.0 90.0)
+ (list 'spectro-y-scale spectro-y-scale #f 0.1 2.0)
+ (list 'spectro-z-angle spectro-z-angle #f 0.0 359.0)
+ (list 'spectro-z-scale spectro-z-scale #f 0.1 0.2)
+ (list 'speed-control speed-control #t 0.1 5.0)
+ (list 'speed-control-style speed-control-style #f 0 2)
+ (list 'speed-control-tones speed-control-tones #f 2 100)
+ (list 'sync sync #t 0 5)
+ (list 'sync-style sync-style #f 0 3)
+ (list 'with-verbose-cursor with-verbose-cursor #f #f #t)
+ (list 'wavelet-type wavelet-type #f 0 10)
+ (list 'time-graph? time-graph? #t #f #t)
+ (list 'x-axis-style x-axis-style #f 0 2)
+ (list 'beats-per-minute beats-per-minute #f 60.0 120.0)
+ (list 'beats-per-measure beats-per-measure #f 4 120)
+ (list 'zero-pad zero-pad #f 0 2)
+ (list 'zoom-focus-style zoom-focus-style #f 0 3))))
+
+ (if (not (equal? *transform-type* fourier-transform))
+ (begin
+ (set! (transform-graph? #t #t) #f)
+ (set! *transform-size* (min *transform-size* 128))))
+ ))
(set! *sinc-width* 10)
(if (pair? open-files) (for-each close-sound open-files))
(set! *sync-style* sync-none)
@@ -26984,12 +26754,6 @@ EDITS: 2
(not (rational? nv)))
(not (fneq nv new-value))
(equal? nv new-value))))
- (define chan-equal?
- (lambda (vals new-value)
- (cond ((null? vals))
- ((pair? vals) (and (chan-equal? (car vals) new-value)
- (chan-equal? (cdr vals) new-value)))
- (else (test-equal vals new-value)))))
(if (not (or (equal? (flatten (func #t #t)) (apply map func (all-chans)))
(equal? (flatten (func #t #t)) (apply map func (all-chans-reversed)))))
(snd-display ";test-history-channel ~A[0]: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans))))
@@ -27012,8 +26776,15 @@ EDITS: 2
(if (not (test-equal nv new-value))
(snd-display ";test-history-channel set-~A[4]: ~A ~A?" name new-value (func snd2 1))))
(set! (func) new-value)
- (if (not (chan-equal? (flatten (func #t #t)) new-value))
- (snd-display ";test-history-channel ~A[5]: ~A ~A?" name (flatten (func #t #t)) (apply map func (all-chans))))
+ (if (not (let chan-equal? ((vals (flatten (func #t #t)))
+ (new-value new-value))
+ (cond ((null? vals))
+ ((pair? vals)
+ (and (chan-equal? (car vals) new-value)
+ (chan-equal? (cdr vals) new-value)))
+ (else (test-equal vals new-value)))))
+ (snd-display ";test-history-channel ~A[5]: ~A ~A?" name (flatten (func #t #t))
+ (apply map func (all-chans))))
(set! (func) old-value)
))
@@ -27189,7 +26960,7 @@ EDITS: 2
(let ((m1 (maxamp obi 0))
(m2 (maxamp s2i 0))
(m3 (maxamp s2i 1))
- (mc (map maxamp (list obi s2i s2i) (list 0 0 1))))
+ (mc (map maxamp (list obi s2i s2i) '(0 0 1))))
(if (or (fneq m1 (car mc))
(fneq m2 (cadr mc))
(fneq m3 (caddr mc)))
@@ -27197,7 +26968,7 @@ EDITS: 2
(set! (sync obi) 1)
(set! (sync s2i) 1)
(do-chans (lambda (val) (* val 2.0)) "*2")
- (let ((mc1 (map maxamp (list obi s2i s2i) (list 0 0 1))))
+ (let ((mc1 (map maxamp (list obi s2i s2i) '(0 0 1))))
(if (or (fneq (* 2.0 m1) (car mc1))
(fneq (* 2.0 m2) (cadr mc1))
(fneq (* 2.0 m3) (caddr mc1)))
@@ -27206,7 +26977,7 @@ EDITS: 2
(set! (sync s2i) 0)
(select-sound s2i)
(do-sound-chans (lambda (val) (* val 0.5)) "/2")
- (let ((mc2 (map maxamp (list obi s2i s2i) (list 0 0 1))))
+ (let ((mc2 (map maxamp (list obi s2i s2i) '(0 0 1))))
(if (or (fneq (* 2.0 m1) (car mc2))
(fneq m2 (cadr mc2))
(fneq m3 (caddr mc2)))
@@ -27307,8 +27078,7 @@ EDITS: 2
(close-sound obi)
)
- (let ((old-srate *clm-srate*))
- (set! *clm-srate* 22050)
+ (let-temporarily ((*clm-srate* 22050))
(let ((ind (new-sound "test.snd" :size 20)))
(set! *print-length* (max *print-length* 20))
(offset-channel 1.0)
@@ -27318,7 +27088,7 @@ EDITS: 2
(len (- (framples ind 0) 1)))
(map-channel (lambda (val)
(sound-interp reader (* len (+ 0.5 (* 0.5 (oscil osc)))))))
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.020 0.079 0.172 0.291 0.427 0.569 0.706 0.825 0.919
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.000 0.020 0.079 0.172 0.291 0.427 0.569 0.706 0.825 0.919
0.979 1.000 0.981 0.923 0.831 0.712 0.576 0.434 0.298 0.177)))
(snd-display ";sound-interp: ~A" (channel->float-vector))))
(undo)
@@ -27331,12 +27101,12 @@ EDITS: 2
(undo)
(env-sound-interp '(0 0 1 1))
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474
0.526 0.579 0.632 0.684 0.737 0.789 0.842 0.895 0.947 1.000)))
(snd-display ";env-sound-interp no change: ~A" (channel->float-vector)))
(undo)
(env-sound-interp '(0 0 1 .95 2 0) 2.0)
- (if (not (vequal (channel->float-vector) (float-vector 0.000 0.050 0.100 0.150 0.200 0.250 0.300 0.350 0.400 0.450
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.000 0.050 0.100 0.150 0.200 0.250 0.300 0.350 0.400 0.450
0.500 0.550 0.600 0.650 0.700 0.750 0.800 0.850 0.900 0.950
1.000 0.950 0.900 0.850 0.800 0.750 0.700 0.650 0.600 0.550
0.500 0.450 0.400 0.350 0.300 0.250 0.200 0.150 0.100 0.050)))
@@ -27349,8 +27119,7 @@ EDITS: 2
(let ((vals (scan-channel (search-for-click))))
(if (not (= vals 11))
(snd-display ";search-for-click: ~A" vals)))
- (close-sound ind))
- (set! *clm-srate* old-srate))
+ (close-sound ind)))
(let ((ind1 (new-sound :size 20 :comment "new-sound for sound-via-sound"))
(ind2 (new-sound :size 20 :comment "second new-sound for sound-via-sound")))
@@ -27359,7 +27128,7 @@ EDITS: 2
(select-sound ind1)
(sound-via-sound ind1 ind2)
(let ((vals (channel->float-vector 0 20 ind1)))
- (if (not (vequal vals (float-vector 0.95 0.90 0.85 0.80 0.75 0.70 0.65 0.60 0.55 0.50 0.45 0.40 0.35 0.30 0.25 0.20 0.15 0.10 0.05 0.00)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.95 0.90 0.85 0.80 0.75 0.70 0.65 0.60 0.55 0.50 0.45 0.40 0.35 0.30 0.25 0.20 0.15 0.10 0.05 0.00)))
(snd-display ";sound-via-sound: ~A" vals)))
(let ((new-file-name (file-name ind2)))
(close-sound ind2)
@@ -27421,10 +27190,10 @@ EDITS: 2
(set! (y-zoom-slider id 0) .5)
(if (fneq (y-zoom-slider id 0) .5) (snd-display ";set y-zoom-slider: ~A?" (y-zoom-slider id 0)))
(let ((vals (channel-amp-envs "oboe.snd" 0 10)))
- (if (not (and (vequal (car vals)
+ (if (not (and (mus-arrays-equal? (car vals)
(float-vector -4.8828125e-4 -0.104156494140625 -0.125213623046875 -0.1356201171875 -0.138916015625
-0.14093017578125 -0.14093017578125 -0.131439208984375 -0.11248779296875 -0.080047607421875))
- (vequal (cadr vals)
+ (mus-arrays-equal? (cadr vals)
(float-vector 0.0 0.10955810546875 0.130706787109375 0.14068603515625 0.141204833984375 0.147247314453125
0.145904541015625 0.140289306640625 0.126861572265625 0.08172607421875))))
(snd-display ";channel-amp-envs: ~A?" vals)))
@@ -27461,8 +27230,8 @@ EDITS: 2
(if (not (= (length (sound-properties id)) (+ len 2)))
(snd-display ";sound-properties: ~A?" (sound-properties id))))
- (let ((tag (catch #t (lambda () (map-channel (lambda (y) "hiho"))) (lambda args args))))
- (if (not (eq? (car tag) 'wrong-type-arg)) (snd-display ";map-channel bad val: ~A" tag)))
+ (let ((tag (catch #t (lambda () (map-channel (lambda (y) (copy "hiho")))) (lambda args args))))
+ (if (not (memq (car tag) '(bad-type wrong-type-arg))) (snd-display ";map-channel bad val: ~A" tag)))
(close-sound id))
@@ -27613,18 +27382,18 @@ EDITS: 2
(key (char->integer #\q) 0 id)
(close-sound id))
- (let ((snd1 (open-sound "oboe.snd"))
- (snd2 (or (open-sound "2.snd") (open-sound "4.aiff")))
- (snd3 (open-sound "4.aiff")))
- (define tests-1
- (lambda (f fn nv)
+ (let ((snd3 (open-sound "4.aiff")))
+ (let ((snd1 (open-sound "oboe.snd"))
+ (snd2 (or (open-sound "2.snd") (open-sound "4.aiff"))))
+ (let tests-1 ((f funcs)
+ (fn func-names)
+ (nv new-values))
(if (pair? f)
(begin
(test-history-channel (car f) (car fn) (car nv) snd1 snd2 snd3)
- (tests-1 (cdr f) (cdr fn) (cdr nv))))))
- (tests-1 funcs func-names new-values)
- (close-sound snd1)
- (close-sound snd2)
+ (tests-1 (cdr f) (cdr fn) (cdr nv)))))
+ (close-sound snd1)
+ (close-sound snd2))
(set! (time-graph-style snd3 #t) graph-filled)
(do ((i 0 (+ i 1))) ((= i 4))
@@ -27687,13 +27456,11 @@ EDITS: 2
(play-with-amps snd2 0.2 0.1))
(close-sound snd2))
- (let ((old-bp *with-background-processes*))
- (set! *with-background-processes* #f)
+ (let-temporarily ((*with-background-processes* #f))
(let* ((ind (open-sound "1a.snd"))
(player (make-player ind 0))
(len (framples ind 0))
- (incr *dac-size*)
- (e (make-env '(0 0 1 1) :length (+ 1 (floor (* 1.0 (/ len incr))))))
+ (e (make-env '(0 0 1 1) :length (+ 1 (floor (* 1.0 (/ len *dac-size*))))))
(samp 0))
(add-player player 0 -1 -1
(lambda (reason)
@@ -27705,10 +27472,9 @@ EDITS: 2
(if (fneq (amp-control ind) 1.0) (snd-display ";amp-control snd: ~A" (amp-control ind)))
(if (> (abs (- (amp-control player) (* 1.0 (/ samp len)))) 1.0)
(snd-display ";amp-control player: ~A ~A" (amp-control player) (* 1.0 (/ samp len))))
- (set! samp (+ samp incr))))
+ (set! samp (+ samp *dac-size*))))
(start-playing 1 (srate ind)))
- (if (find-sound "1a.snd") (snd-display ";stop proc didn't close?"))
- (set! *with-background-processes* old-bp))
+ (if (find-sound "1a.snd") (snd-display ";stop proc didn't close?")))
(let ((ind (open-sound "pistol.snd")))
(if (selection-member? ind 0)
@@ -27819,10 +27585,10 @@ EDITS: 2
(snd-display ";src-fit-envelope 0.5: ~A" (src-duration (src-fit-envelope '(0 1 1 2) 0.5))))
- (if (fneq (fm-parallel-component 100 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t) 0.69287)
- (snd-display ";fm-parallel-component 100: ~A" (fm-parallel-component 100 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t)))
- (if (fneq (fm-parallel-component 500 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t) 0.17047)
- (snd-display ";fm-parallel-component 500: ~A" (fm-parallel-component 500 100.0 (list 100.0 300.0 400.0) (list 1.0 0.5 0.25) () () #t)))
+ (if (fneq (fm-parallel-component 100 100.0 '(100.0 300.0 400.0) '(1.0 0.5 0.25) () () #t) 0.69287)
+ (snd-display ";fm-parallel-component 100: ~A" (fm-parallel-component 100 100.0 '(100.0 300.0 400.0) '(1.0 0.5 0.25) () () #t)))
+ (if (fneq (fm-parallel-component 500 100.0 '(100.0 300.0 400.0) '(1.0 0.5 0.25) () () #t) 0.17047)
+ (snd-display ";fm-parallel-component 500: ~A" (fm-parallel-component 500 100.0 '(100.0 300.0 400.0) '(1.0 0.5 0.25) () () #t)))
(if (fneq (cheby-hka 3 0.25 (float-vector 0 0 0 0 1.0 1.0)) -0.0732421875)
(snd-display ";cheby-hka 0: ~A" (cheby-hka 3 0.25 (float-vector 0 0 0 0 1.0 1.0))))
@@ -27847,8 +27613,8 @@ EDITS: 2
(fneq (cadr vals) 1.0))
(snd-display ";src ~A freq: ~A" sr vals)))
(undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
+ '(2.0 0.5 5.0 0.2)
+ '(0.5 2.0 0.2 5.0))
(for-each
(lambda (e f0 f1)
(src-sound e 1.0 ind 0)
@@ -27862,9 +27628,9 @@ EDITS: 2
(if (f5neq (car vals) f1)
(snd-display ";src (env) 1 ~A freq: ~A" f1 vals)))
(undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
- (list 500.0 1000.0 500.0 250.0 250.0)
- (list 1000.0 500.0 500.0 500.0 1000.0))
+ '((0 1 1 2) (0 2 1 1) (0 1 1 2 2 1) (0 0.5 1 1) (0 0.5 1 2))
+ '(500.0 1000.0 500.0 250.0 250.0)
+ '(1000.0 500.0 500.0 500.0 1000.0))
(for-each
(lambda (e f0 f1)
(src-sound (make-env e :length (framples)) 1.0 ind 0)
@@ -27878,9 +27644,9 @@ EDITS: 2
(if (f5neq (car vals) f1)
(snd-display ";src (env) 1 ~A freq: ~A" f1 vals)))
(undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
- (list 500.0 1000.0 500.0 250.0 250.0)
- (list 1000.0 500.0 500.0 500.0 1000.0))
+ '((0 1 1 2) (0 2 1 1) (0 1 1 2 2 1) (0 0.5 1 1) (0 0.5 1 2))
+ '(500.0 1000.0 500.0 250.0 250.0)
+ '(1000.0 500.0 500.0 500.0 1000.0))
(for-each
(lambda (sr dur)
@@ -27891,8 +27657,8 @@ EDITS: 2
(fneq (cadr vals) 1.0))
(snd-display ";src ~A freq: ~A" sr vals)))
(undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
+ '(2.0 0.5 5.0 0.2)
+ '(0.5 2.0 0.2 5.0))
(for-each
(lambda (e f0 f1)
(src-channel e)
@@ -27906,9 +27672,9 @@ EDITS: 2
(if (f5neq (car vals) f1)
(snd-display ";src-channel (env f1) ~A: ~A" f1 vals)))
(undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2))
- (list 500.0 1000.0 500.0 250.0 250.0)
- (list 1000.0 500.0 500.0 500.0 1000.0))
+ '((0 1 1 2) (0 2 1 1) (0 1 1 2 2 1) (0 0.5 1 1) (0 0.5 1 2))
+ '(500.0 1000.0 500.0 250.0 250.0)
+ '(1000.0 500.0 500.0 500.0 1000.0))
(for-each
(lambda (sr dur)
@@ -27925,8 +27691,8 @@ EDITS: 2
(if (f5neq (car vals) (* sr 500.0))
(snd-display ";src-channel section ~A freq: ~A" sr vals)))
(undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
+ '(2.0 0.5 5.0 0.2)
+ '(0.5 2.0 0.2 5.0))
(for-each
(lambda (e)
@@ -27941,7 +27707,7 @@ EDITS: 2
(if (f5neq (car vals) 500.0)
(snd-display ";src-channel section (make-env e) ~A: ~A" e vals)))
(undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
+ '((0 1 1 2) (0 2 1 1) (0 1 1 2 2 1) (0 0.5 1 1) (0 0.5 1 2)))
(make-selection 1000 3500 ind 0)
(for-each
@@ -27959,8 +27725,8 @@ EDITS: 2
(if (f5neq (car vals) (* sr 500.0))
(snd-display ";src-selection section ~A freq: ~A" sr vals)))
(undo))
- (list 2.0 0.5 5.0 0.2)
- (list 0.5 2.0 0.2 5.0))
+ '(2.0 0.5 5.0 0.2)
+ '(0.5 2.0 0.2 5.0))
(for-each
(lambda (e)
@@ -27975,7 +27741,7 @@ EDITS: 2
(if (f5neq (car vals) 500.0)
(snd-display ";src-selection section (make-env e) ~A: ~A" e vals)))
(undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
+ '((0 1 1 2) (0 2 1 1) (0 1 1 2 2 1) (0 0.5 1 1) (0 0.5 1 2)))
(for-each
(lambda (e)
@@ -27990,10 +27756,9 @@ EDITS: 2
(if (f5neq (car vals) 500.0)
(snd-display ";src-selection section (env f1) ~A: ~A" e vals)))
(undo))
- (list (list 0 1 1 2) (list 0 2 1 1) (list 0 1 1 2 2 1) (list 0 .5 1 1) (list 0 .5 1 2)))
+ '((0 1 1 2) (0 2 1 1) (0 1 1 2 2 1) (0 0.5 1 1) (0 0.5 1 2)))
- (close-sound ind)
- )
+ (close-sound ind))
(set! *print-length* (max *print-length* 12))
(let ((ind (new-sound "hi.snd")))
@@ -28003,7 +27768,7 @@ EDITS: 2
(select-all ind)
(set! (sample 10 ind) 1.0)
(smooth-selection)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0) 0 9)))
+ (if (not (mus-arrays-equal? (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0) 0 9)))
(snd-display ";smooth-selection: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 0.0 1.0)))
(revert-sound)
(do ((i 0 (+ i 1)))
@@ -28012,7 +27777,7 @@ EDITS: 2
(select-all ind)
(set! (sample 10 ind) 0.0)
(smooth-selection)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0) 0 9)))
+ (if (not (mus-arrays-equal? (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0) 0 9)))
(snd-display ";smooth-selection back: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 1.0 0.0)))
(close-sound ind))
@@ -28022,7 +27787,7 @@ EDITS: 2
(set! (sample i ind) (* i .1)))
(set! (sample 10 ind) 1.0)
(smooth-sound 0 10 ind)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0) 0 9)))
+ (if (not (mus-arrays-equal? (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 0.0 1.0) 0 9)))
(snd-display ";smooth-sound: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 0.0 1.0)))
(revert-sound)
(do ((i 0 (+ i 1)))
@@ -28030,7 +27795,7 @@ EDITS: 2
(set! (sample i ind) (- 1.0 (* i .1))))
(set! (sample 10 ind) 0.0)
(smooth-sound 0 10 ind)
- (if (not (vequal (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0) 0 9)))
+ (if (not (mus-arrays-equal? (float-vector-subseq (channel->float-vector 0 11 ind) 0 9) (float-vector-subseq (smoother 1.0 0.0) 0 9)))
(snd-display ";smooth-sound back: ~A ~A?" (channel->float-vector 0 11 ind) (smoother 1.0 0.0)))
(close-sound ind))
(if (file-exists? "hi.snd") (delete-file "hi.snd"))
@@ -28289,8 +28054,8 @@ EDITS: 2
(let ((v1 (multiply-envelopes '(0.0 0.0 2.0 0.5) '(0.0 0.0 1.0 2.0 2.0 1.0)))
(v2 (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0))))
- (if (not (feql v1 (list 0.0 0.0 0.5 0.5 1.0 0.5))) (snd-display ";multiply-envelopes: ~A?" v1))
- (if (not (feql v2 (list 1.0 0.2 3.0 0.6))) (snd-display ";window-envelope: ~A?" v2)))
+ (if (not (feql v1 '(0.0 0.0 0.5 0.5 1.0 0.5))) (snd-display ";multiply-envelopes: ~A?" v1))
+ (if (not (feql v2 '(1.0 0.2 3.0 0.6))) (snd-display ";window-envelope: ~A?" v2)))
(if (fneq (envelope-interp .1 '(0 0 1 1)) 0.1)
(snd-display ";envelope-interp .1 -> ~A?" (envelope-interp .1 '(0 0 1 1))))
@@ -28336,9 +28101,9 @@ EDITS: 2
(if (fneq (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) .012) 0.993)
(snd-display ";envelope-interp .993 (3) -> ~A?" (envelope-interp 1.9 '(0 0 0.5 1 1 0 2 1) .012)))
- (if (not (feql (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) (list 1.0 0.2 3.0 0.6)))
+ (if (not (feql (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) '(1.0 0.2 3.0 0.6)))
(snd-display ";window-envelope: ~A?" (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0))))
- (if (not (feql (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0)) (list 0 0 0.5 0.5 1 0)))
+ (if (not (feql (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0)) '(0 0 0.5 0.5 1 0)))
(snd-display ";multiply-envelopes: ~A?" (multiply-envelopes '(0 0 1 1) '(0 0 1 1 2 0))))
(if (fneq (max-envelope '(0 0 1 1 2 3 4 0)) 3.0)
(snd-display ";max-envelope: ~A?" (max-envelope '(0 0 1 1 2 3 4 0))))
@@ -28366,9 +28131,9 @@ EDITS: 2
(snd-display ";integrate-envelope: ~A?" (integrate-envelope '(0 1 1 1))))
(if (fneq (integrate-envelope '(0 0 1 1 2 .5)) 1.25)
(snd-display ";integrate-envelope: ~A?" (integrate-envelope '(0 0 1 1 2 .5))))
- (if (not (feql (stretch-envelope '(0 0 1 1) .1 .2) (list 0 0 0.2 0.1 1.0 1)))
+ (if (not (feql (stretch-envelope '(0 0 1 1) .1 .2) '(0 0 0.2 0.1 1.0 1)))
(snd-display ";stretch-envelope att: ~A?" (stretch-envelope '(0 0 1 1) .1 .2)))
- (if (not (feql (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6) (list 0 0 0.2 0.1 1.1 1 1.6 0.5 2.0 0)))
+ (if (not (feql (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6) '(0 0 0.2 0.1 1.1 1 1.6 0.5 2.0 0)))
(snd-display ";stretch-envelope dec: ~A?" (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6)))
(if (not (feql (add-envelopes '(0 0 1 1 2 0) '(0 0 1 1)) '(0 0 0.5 1.5 1 1)))
(snd-display ";add-envelopes: ~A" (add-envelopes '(0 0 1 1 2 0) '(0 0 1 1))))
@@ -28417,12 +28182,12 @@ EDITS: 2
(scale-selection-to 0.5)
(insert-selection 15 ind)
(if (not (= (framples ind) 25)) (snd-display ";insert-selection 5: ~A" (framples ind)))
- (if (not (vequal (channel->float-vector 0 25) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
+ (if (not (mus-arrays-equal? (channel->float-vector 0 25) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5
1.0 1.0 1.0 1.0 1.0)))
(snd-display ";insert-selection: ~A" (channel->float-vector 0 25)))
(mix-selection 1 ind 0) ; this is being confused by clipping settings
- (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector 1.000 1.500 1.500 1.500 1.500 1.000 0.500 0.500 0.500 0.500)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 0) (float-vector 1.000 1.500 1.500 1.500 1.500 1.000 0.500 0.500 0.500 0.500)))
(snd-display ";mix-selection vals: ~A" (channel->float-vector 0 10 ind 0)))
(close-sound ind))
@@ -28462,7 +28227,7 @@ EDITS: 2
(pval (data (floor (* .1 (length data))))))
(if (> (* .5 peak) pval)
(snd-display ";transform selection padded ~D: ~A, peak: ~A" pad pval peak))))
- (list 1 0 3 31))
+ '(1 0 3 31))
(set! *zero-pad* 100000)
(if (> *zero-pad* 1000)
(snd-display ";zero-pad: ~A" *zero-pad*))
@@ -28493,7 +28258,7 @@ EDITS: 2
(vc (vector .1 .2 .3 .4))
(lst (list 1 2 3 4 5))
(hsh (make-hash-table 100))
- (sd (make-float-vector (list 1 10) 0.0))
+ (sd (make-float-vector '(1 10)))
(str "123456"))
(let ((mxv (mix-float-vector v 1000))
(reg (make-region 0 100))
@@ -28531,7 +28296,7 @@ EDITS: 2
(let ((snd (open-sound "oboe.snd"))
(v (float-vector .1 .2 .3))
- (sd (make-float-vector (list 2 10) 0.0)))
+ (sd (make-float-vector '(2 10))))
(let ((mxv (mix-float-vector v 1000))
(reg (make-region 0 100))
(ply (make-player snd 0))
@@ -28551,7 +28316,7 @@ EDITS: 2
(let ((snd (open-sound "oboe.snd"))
(v (float-vector .1 .2 .3))
- (sd (make-float-vector (list 1 10) 0.0)))
+ (sd (make-float-vector '(1 10))))
(let ((mxv (mix-float-vector v 1000))
(reg (make-region 0 100))
(dly (make-delay 32))
@@ -28617,7 +28382,7 @@ EDITS: 2
(if (fneq (maxamp vc) .4) (snd-display ";maxamp of vector: ~A" (maxamp vc))))
(let ((str "pistol.snd")) ; can't use oboe.snd since we messed with mus-sound-maxamp above
(if (fneq (maxamp str) .49267) (snd-display ";maxamp of string: ~A" (maxamp str))))
- (let ((sd (make-float-vector (list 1 10) 0.0)))
+ (let ((sd (make-float-vector '(1 10))))
(set! (sd 0 1) .1)
(if (fneq (maxamp sd) 0.1) (snd-display ";maxamp of vector2: ~A" (maxamp sd))))
(if (fneq (maxamp mxv) .3) (snd-display ";maxamp of mix: ~A" (maxamp mxv)))
@@ -28643,7 +28408,7 @@ EDITS: 2
((or unhappy (> i len))
unhappy)
(let ((ed (edit-fragment i s c)))
- (if (and ed
+ (if (and (pair? ed)
(string=? (cadr ed) "env"))
(begin
(set! (edit-position s c) (- i 1))
@@ -28949,9 +28714,9 @@ EDITS: 2
(define (amp-envs-equal? snd chn pos0 pos1 df)
(let* ((env0 (channel-amp-envs snd chn pos0))
- (len0 (and env0 (pair? env0) (= (length env0) 2) (length (cadr env0))))
+ (len0 (and (pair? env0) (= (length env0) 2) (length (cadr env0))))
(env1 (channel-amp-envs snd chn pos1))
- (len1 (and env1 (pair? env1) (= (length env1) 2) (length (cadr env1))))
+ (len1 (and (pair? env1) (= (length env1) 2) (length (cadr env1))))
(happy #t))
(and len0 len1
(let* ((minlen (min len0 len1))
@@ -29011,7 +28776,7 @@ EDITS: 2
(sqrt (one-pole incr 0.0))))
(define (check-edit-tree-1 expected-tree expected-vals name line)
- (define (vequal-at v0 v1)
+ (define (mus-arrays-equal?-at v0 v1)
(call-with-exit
(lambda (return)
(let ((len (length v0)))
@@ -29038,10 +28803,9 @@ EDITS: 2
(len (length current-vals)))
(if (and expected-vals (not (= len (length expected-vals))))
(snd-display ";~A (from ~A): lengths differ: ~A ~A" name line len (length expected-vals))
- (if (and expected-vals (not (vequal current-vals expected-vals)))
- (snd-display ";checking ~A (from ~A), vals disagree (loc cur expect): ~A" name line (vequal-at current-vals expected-vals))
- (let* ((tree (edit-tree))
- (bad-data (edits-not-equal? tree expected-tree 0)))
+ (if (and expected-vals (not (mus-arrays-equal? current-vals expected-vals)))
+ (snd-display ";checking ~A (from ~A), vals disagree (loc cur expect): ~A" name line (mus-arrays-equal?-at current-vals expected-vals))
+ (let ((bad-data (edits-not-equal? (edit-tree) expected-tree 0)))
(if bad-data
(snd-display ";checking ~A (from ~A), trees disagree (loc cur expect): ~A~% in~%~A" name line bad-data (edit-tree)))
(if (> len 5)
@@ -29055,13 +28819,10 @@ EDITS: 2
(do ((i (- split-loc 1) (- i 1)))
((< i 0))
(float-vector-set! split-vals i (read-sample bread)))
- (if (and expected-vals (not (vequal split-vals expected-vals)))
+ (if (and expected-vals (not (mus-arrays-equal? split-vals expected-vals)))
(snd-display ";checking ~A (from ~A), split vals disagree (loc cur expect): ~A"
- name line (vequal-at split-vals expected-vals))))))))))
+ name line (mus-arrays-equal?-at split-vals expected-vals))))))))))
- (define-expansion (check-edit-tree tree vals name)
- `(check-edit-tree-1 ,tree ,vals ,name ,(port-line-number)))
-
(define (zigzag-check name snd chn)
(let ((data (channel->float-vector))
(sf (make-sampler 3 snd chn)))
@@ -29095,11 +28856,11 @@ EDITS: 2
data))
(let ((happy #t))
- (if (not (vequal v (channel->float-vector 0 (framples) ind 0)))
+ (if (not (mus-arrays-equal? v (channel->float-vector 0 (framples) ind 0)))
(begin
(set! happy #f)
(snd-display ";~A forth:~% current: ~A~% expected: ~A" name (channel->float-vector 0 (framples) ind 0) v)))
- (if (not (vequal v (reversed-read ind 0)))
+ (if (not (mus-arrays-equal? v (reversed-read ind 0)))
(begin
(set! happy #f)
(snd-display ";~A back: ~A ~A" name (reversed-read ind 0) v)))
@@ -29121,7 +28882,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i res-len))
(let ((sum 0.0))
- (do ((j (max 0 (+ 1 (- i v2-len))) (+ j 1)))
+ (do ((j (max 0 (- (+ i 1) v2-len)) (+ j 1)))
((> j (min i (- v1-len 1))))
(set! sum (+ sum (* (v1 j)
(v2 (- i j))))))
@@ -29154,11 +28915,8 @@ EDITS: 2
(lambda () (set-samples 0 0 (make-float-vector 3) oboe))
(lambda () (smooth-sound 0 0 oboe))
(lambda () (insert-silence 0 0 oboe)))
- (list
- "scale-channel" "env-channel" "clm-channel" "float-vector->channel" "smooth-channel" "pad-channel" "src-channel"
- "mix-channel" "insert-channel" "reverse-channel" "play"
- "scale-sound-by" "env-sound" "set-samples" "smooth-sound" "insert-silence"))
-
+ '("scale-channel" "env-channel" "clm-channel" "float-vector->channel" "smooth-channel" "pad-channel" "src-channel"
+ "mix-channel" "insert-channel" "reverse-channel" "play" "scale-sound-by" "env-sound" "set-samples" "smooth-sound" "insert-silence"))
(for-each
(lambda (func name)
(let ((tag (catch #t
@@ -29184,10 +28942,8 @@ EDITS: 2
(lambda () (set-samples -1 123 (make-float-vector 3) oboe))
(lambda () (smooth-sound -1 123 oboe))
(lambda () (insert-silence -1 123 oboe)))
- (list
- "scale-channel" "env-channel" "clm-channel" "float-vector->channel" "smooth-channel" "pad-channel" "src-channel"
- "mix-channel" "insert-channel" "reverse-channel"
- "scale-sound-by" "env-sound" "set-samples" "smooth-sound" "insert-silence"))
+ '("scale-channel" "env-channel" "clm-channel" "float-vector->channel" "smooth-channel" "pad-channel" "src-channel" "mix-channel"
+ "insert-channel" "reverse-channel" "scale-sound-by" "env-sound" "set-samples" "smooth-sound" "insert-silence"))
(scale-channel 2.0 12345678 123 oboe)
(if (not (= (edit-position oboe) 0))
@@ -29247,8 +29003,7 @@ EDITS: 2
(if (not (= (edit-position oboe) 12))
(snd-display ";oboe clm-channel granulate? ~A ~A" (edit-position oboe) (edit-fragment))))
(let* ((rd (make-sampler 0))
- (flt (float-vector 1.0 0.0 0.0 0.0))
- (sr (make-convolve :input (lambda (dir) (read-sample rd)) :filter flt)))
+ (sr (make-convolve :input (lambda (dir) (read-sample rd)) :filter (float-vector 1.0 0.0 0.0 0.0))))
(clm-channel sr 0 12345 oboe 0)
(if (not (= (edit-position oboe) 13))
(snd-display ";oboe clm-channel convolve? ~A ~A" (edit-position oboe) (edit-fragment))))
@@ -29291,12 +29046,12 @@ EDITS: 2
(let ((oldv (channel->float-vector 1000 10 oboe)))
(mix-channel "oboe.snd" 0)
(float-vector-scale! oldv 2.0)
- (if (not (vequal oldv (channel->float-vector 1000 10 oboe)))
+ (if (not (mus-arrays-equal? oldv (channel->float-vector 1000 10 oboe)))
(snd-display ";mix-channel at 0: ~A ~A" oldv (channel->float-vector 1000 10 oboe)))
(revert-sound oboe)
(float-vector-scale! oldv 0.5)
(insert-channel "oboe.snd" 0)
- (if (not (vequal oldv (channel->float-vector 1000 10 oboe)))
+ (if (not (mus-arrays-equal? oldv (channel->float-vector 1000 10 oboe)))
(snd-display ";insert-channel at 0: ~A ~A" oldv (channel->float-vector 1000 10 oboe)))
(if (not (= (framples oboe 0) (* 2 (framples oboe 0 0))))
(snd-display ";insert-channel framples: ~A ~A" (framples oboe 0) (framples oboe 0 0)))
@@ -29311,42 +29066,42 @@ EDITS: 2
(let ((val (mix-channel "fmv.snd")))
(if (mix? val)
(snd-display ";mix-channel returned a mix: ~A?" val)))
- (if (not (vequal (channel->float-vector 0 #f ind 1) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 1) (make-float-vector 10)))
(snd-display ";mix-channel mixed channel 1: ~A?" (channel->float-vector 0 #f ind 1)))
- (if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector 0 0 0 .5 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 0) (float-vector 0 0 0 .5 0 0 0 0 0 0)))
(snd-display ";mix-channel chan 0: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(let ((val (mix-channel (list "fmv.snd" 2 1) 0 #f ind 0)))
(if (mix? val)
(snd-display ";mix-channel 2 returned a mix: ~A?" val)))
- (if (not (vequal (channel->float-vector 0 #f ind 1) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 1) (make-float-vector 10)))
(snd-display ";mix-channel mixed channel 1a: ~A?" (channel->float-vector 0 #f ind 1)))
- (if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
(snd-display ";mix-channel chan 0a: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(set! (sample 2 ind 1) -.4)
(let ((val (mix-channel (list ind 2 1) 0 #f ind 0 -1 #t)))
(if (not (mix? val))
(snd-display ";mix-channel with-tag: ~A" val)))
- (if (not (vequal (channel->float-vector 0 #f ind 1) (float-vector 0 0 -.4 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 1) (float-vector 0 0 -.4 0 0 0 0 0 0 0)))
(snd-display ";mix-channel mixed channel 1b: ~A?" (channel->float-vector 0 #f ind 1)))
- (if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
(snd-display ";mix-channel chan 0b: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(let ((val (car (mix-channel (list "fmv.snd" 2 1) 0 #f ind 0 -1 #t))))
(if (not (mix? val))
(snd-display ";mix-channel file with-tag: ~A" val)))
- (if (not (vequal (channel->float-vector 0 #f ind 1) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 1) (make-float-vector 10)))
(snd-display ";mix-channel mixed channel 1c: ~A?" (channel->float-vector 0 #f ind 1)))
- (if (not (vequal (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 0) (float-vector -.4 0 0 0 0 0 0 0 0 0)))
(snd-display ";mix-channel chan 0c: ~A" (channel->float-vector 0 #f ind 0)))
(revert-sound ind)
(let ((val (car (mix-channel (list "fmv.snd") 0 #f ind 1 -1 #t))))
(if (not (mix? val))
(snd-display ";mix-channel file 1 with-tag: ~A" val)))
- (if (not (vequal (channel->float-vector 0 #f ind 0) (make-float-vector 10 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 0) (make-float-vector 10)))
(snd-display ";mix-channel mixed channel 0d: ~A?" (channel->float-vector 0 #f ind 1)))
- (if (not (vequal (channel->float-vector 0 #f ind 1) (float-vector 0 0 0 .5 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 #f ind 1) (float-vector 0 0 0 .5 0 0 0 0 0 0)))
(snd-display ";mix-channel chan 1d: ~A" (channel->float-vector 0 #f ind 1)))
(revert-sound ind)
(if (file-exists? "fmv.snd") (delete-file "fmv.snd"))
@@ -29360,41 +29115,41 @@ EDITS: 2
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 20))
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? v1 (float-vector 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)))
(snd-display ";env-channel step 1: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 20) 8)
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 1)))
+ (if (not (mus-arrays-equal? v1 (float-vector 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 1)))
(snd-display ";env-channel step 1 at 8: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 12))
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? v1 (float-vector 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(snd-display ";env-channel step 1 at 0: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 12) 4)
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 1 1 1 1 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? v1 (float-vector 1 1 1 1 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1)))
(snd-display ";env-channel step 1 at 4: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1) :base 0 :length 12) 4 3)
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? v1 (float-vector 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(snd-display ";env-channel step 1 at 4 by 3: ~A" v1)))
(undo)
(env-channel (make-env '(0 1 1 0 2 0) :base 0 :length 8) 0 12)
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? v1 (float-vector 1 1 1 1 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1)))
(snd-display ";env-channel step 1 at 0 for 7: ~A" v1)))
(undo)
(env-channel (make-env '(0 0 1 1 2 1 3 0 4 0) :base 0 :length 20))
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? v1 (float-vector 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0)))
(snd-display ";env-channel step 1: ~A" v1)))
(env-channel (make-env '(0 0 1 .5 2 .25 3 0 4 0) :base 0 :length 21))
(let ((v1 (channel->float-vector)))
- (if (not (vequal v1 (float-vector 0 0 0 0 0 0 .5 .5 .5 .5 .5 .25 .25 .25 .25 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? v1 (float-vector 0 0 0 0 0 0 .5 .5 .5 .5 .5 .25 .25 .25 .25 0 0 0 0 0)))
(snd-display ";env-channel step 1 (.5): ~A" v1)))
(close-sound ind))
@@ -29425,7 +29180,7 @@ EDITS: 2
(define (funcs-equal? name func0 func1)
(func0 #f #f oboe0)
(func1 #f #f oboe1)
- (if (not (vequal (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(snd-display ";~A via #f: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(revert-sound oboe0)
(revert-sound oboe1)
@@ -29433,13 +29188,13 @@ EDITS: 2
(func0)
(select-sound oboe1)
(func1)
- (if (not (vequal (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(snd-display ";~A via none: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(revert-sound oboe0)
(revert-sound oboe1)
(func0 0 (framples oboe0) oboe0)
(func1 0 (framples oboe1) oboe1)
- (if (not (vequal (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(snd-display ";~A via framples: ~A ~A" name (channel->float-vector 1000 100 oboe0) (channel->float-vector 1000 100 oboe1)))
(revert-sound oboe0)
(revert-sound oboe1))
@@ -29457,7 +29212,7 @@ EDITS: 2
smooth-sound
smooth-channel)
(funcs-equal? "env-sound"
- (lambda args (env-sound (list 0 0 1 1)
+ (lambda args (env-sound '(0 0 1 1)
(if (> (length args) 0) (car args) 0)
(and (> (length args) 1)
(number? (cadr args))
@@ -29467,7 +29222,7 @@ EDITS: 2
(caddr args)
(selected-sound))))
(lambda args (apply env-channel
- (make-env :envelope (list 0 0 1 1)
+ (make-env :envelope '(0 0 1 1)
:length (if (and (> (length args) 1)
(number? (cadr args)))
(cadr args)
@@ -29508,7 +29263,7 @@ EDITS: 2
(if (not (sound? ind))
(snd-display ";save hiho failed?")
(let ((new-vals (channel->float-vector 12295 200 ind 0)))
- (if (not (vequal vals new-vals))
+ (if (not (mus-arrays-equal? vals new-vals))
(snd-display ";save state hiho vals: ~A ~A" vals new-vals))))
(close-sound ind))
(set! *save-dir* old-save-dir))
@@ -29550,10 +29305,10 @@ EDITS: 2
(list
(lambda (posfunc)
(let ((chn (min (random (+ 1 out-chans)) (- out-chans 1))))
- (if (not (vequal (channel->float-vector 0 (framples ind chn) ind chn 0) (float-vector 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 (framples ind chn) ind chn 0) (float-vector 0.0)))
(snd-display ";start bad: ~A" (channel->float-vector 0 (framples ind chn) ind chn 0)))
(set! (sample 0 ind chn) .1)
- (if (not (vequal (channel->float-vector 0 (framples ind chn) ind chn) (float-vector 0.1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 (framples ind chn) ind chn) (float-vector 0.1)))
(snd-display ";set bad: ~A" (channel->float-vector 0 (framples ind chn) ind chn)))
(pad-channel 0 1 ind chn (posfunc))
(let ((pos (posfunc)))
@@ -29561,12 +29316,12 @@ EDITS: 2
(set! pos (pos ind chn)))
(let ((data (channel->float-vector 0 (framples ind chn) ind chn)))
(if (or (and (= pos 0)
- (not (vequal data (float-vector 0.0 0.0))))
+ (not (mus-arrays-equal? data (float-vector 0.0 0.0))))
(and (or (= pos current-edit-position)
(= pos (edit-position ind chn)))
- (not (vequal data (float-vector 0.0 0.1))))
+ (not (mus-arrays-equal? data (float-vector 0.0 0.1))))
(and (= pos (- (edit-position ind chn) 1))
- (not (vequal data (float-vector 0.0 0.0)))))
+ (not (mus-arrays-equal? data (float-vector 0.0 0.0)))))
(snd-display ";pos[~A]: edpos ~A of ~A, pad result[~A, ~A]: ~A"
chn pos (edit-position ind chn) (framples ind chn pos) (framples ind chn) data))
(if (> (chans ind) 1)
@@ -29574,7 +29329,7 @@ EDITS: 2
((= i (chans ind)))
(if (not (= i chn))
(let ((data (channel->float-vector 0 (framples ind i) ind i)))
- (if (not (vequal data (float-vector 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0)))
(snd-display ";pad[~A / ~A] empty: ~A" i chn data))))))))))
(lambda (posfunc)
(let ((chn (min (random (+ 1 out-chans)) (- out-chans 1))))
@@ -29584,12 +29339,12 @@ EDITS: 2
(if (procedure? pos) (set! pos (pos ind chn)))
(let ((data (channel->float-vector 0 (framples ind chn) ind chn)))
(if (or (and (= pos 0)
- (not (vequal data (float-vector 0.0))))
+ (not (mus-arrays-equal? data (float-vector 0.0))))
(and (or (= pos current-edit-position)
(= pos (edit-position ind chn)))
- (not (vequal data (float-vector 0.2))))
+ (not (mus-arrays-equal? data (float-vector 0.2))))
(and (= pos (- (edit-position ind chn) 1))
- (not (vequal data (float-vector 0.0)))))
+ (not (mus-arrays-equal? data (float-vector 0.0)))))
(snd-display ";pos[~A]: edpos ~A of ~A, set *2 result[~A, ~A]: ~A"
chn pos (edit-position ind chn) (framples ind chn pos) (framples ind chn) data))
(if (> (chans ind) 1)
@@ -29597,20 +29352,20 @@ EDITS: 2
((= i (chans ind)))
(if (not (= i chn))
(let ((data (channel->float-vector 0 (framples ind i) ind i)))
- (if (not (vequal data (float-vector 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0)))
(snd-display ";scale[~A / ~A] empty: ~A" i chn data)))))))))))))
- (list "2a.snd" "1a.snd" "4a.snd"))
+ '("2a.snd" "1a.snd" "4a.snd"))
(close-sound ind)))
- (list 1 2 4))
+ '(1 2 4))
(let ((ind (open-sound "oboe.snd")))
(map-channel (lambda (y) #f))
(if (not (= (framples ind) 0)) (snd-display ";map-channel #f framples: ~A" (framples ind)))
- (if (equal? (edits ind) (list 0 0)) (snd-display ";map-channel #f edits backed up"))
+ (if (equal? (edits ind) '(0 0)) (snd-display ";map-channel #f edits backed up"))
(undo 1 ind)
(if (= (framples ind) 0) (snd-display ";map-channel #f framples after undo: ~A" (framples ind)))
- (let ((tag (catch #t (lambda () (map-channel (lambda (y) "hiho"))) (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) (snd-display ";map-channel bad-type: ~A" tag)))
+ (let ((tag (catch #t (lambda () (map-channel (lambda (y) (copy "hiho")))) (lambda args (car args)))))
+ (if (not (memq tag '(bad-type wrong-type-arg))) (snd-display ";map-channel bad-type: ~A" tag)))
(let* ((ctr 0)
(tag (catch #t (lambda () (scan-channel (lambda (y) (set! ctr (+ ctr 1)) (asdf)))) (lambda args (car args)))))
(if (not (= ctr 1)) (snd-display ";scan-channel error exit: ~A" ctr))
@@ -29620,10 +29375,9 @@ EDITS: 2
(let ((val (scan-channel (lambda (y) #f) 1234))) (if val (snd-display ";scan-channel func #f with beg: ~A" val)))
(let ((val (scan-channel (lambda (y) #f) 1234 4321))) (if val (snd-display ";scan-channel func #f with beg+dur: ~A" val)))
(revert-sound ind)
- (let ((del (make-delay 1000)))
- (clm-channel del 0 (framples) ind 0 0 2000))
+ (clm-channel (make-delay 1000) 0 (framples) ind 0 0 2000) ; chn=0, edpos=0, overlap=2000?
(let ((len (framples)))
- (if (not (= (framples ind) (+ 2000 len)))
+ (if (not (= len 52828))
(snd-display ";clm-channel overlap length: ~A ~A" len (framples)))
(if (not (equal? (edit-tree) '((0 1 0 52827 1.0 0.0 0.0 0) (52828 -2 0 0 0.0 0.0 0.0 0))))
(snd-display ";clm-channel overlaps: ~A" (edit-tree)))
@@ -29645,7 +29399,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i len))
(float-vector-set! v1 i (read-sample reader)))
- (if (not (vequal v0 v1))
+ (if (not (mus-arrays-equal? v0 v1))
(snd-display ";clm-channel overlap main: ~A ~A" v0 v1)))
(do ((i 0 (+ i 1)))
((or (not happy) (= i 1000)))
@@ -30015,7 +29769,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i dur))
(float-vector-set! v1 i (e)))))
- (if (not (vequal v0 v1))
+ (if (not (mus-arrays-equal? v0 v1))
(snd-display ";~A env check [~A]: ~A ~A" name r rv ev))))
(float-vector->channel v)
@@ -30071,8 +29825,8 @@ EDITS: 2
(* val .5)
val)))))
(undo 2)))
- (list 0 0 1000 1000 4000 5000 6000 5000)
- (list 1000 6000 1000 4000 2000 1000 1000 5000)))
+ '(0 0 1000 1000 4000 5000 6000 5000)
+ '(1000 6000 1000 4000 2000 1000 1000 5000)))
(when (= dur 10000)
(for-each
(lambda (env-beg env-dur scl-beg scl-dur)
@@ -30093,10 +29847,10 @@ EDITS: 2
(set! val (* val 0.5)))
val))))
(undo 2)))
- (list 0 0 1000 1000 4000 5000 6000 5000)
- (list 1000 6000 1000 4000 2000 1000 1000 5000)
- (list 500 0 0 2000 5000 4000 0 8000)
- (list 200 10000 1500 1000 500 2000 2000 2000)))
+ '(0 0 1000 1000 4000 5000 6000 5000)
+ '(1000 6000 1000 4000 2000 1000 1000 5000)
+ '(500 0 0 2000 5000 4000 0 8000)
+ '(200 10000 1500 1000 500 2000 2000 2000)))
(env-sound '(0 0 1 1))
(env-sound '(0 0 1 1))
(check-env 'unenv-ramp
@@ -30110,7 +29864,7 @@ EDITS: 2
(let ((v1 (make-float-vector 3 1.0)))
(float-vector->channel v1 3 3)
(let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
(snd-display "; 1 vals: ~A" vals))))
(undo 2)
(env-sound '(0 0 1 1))
@@ -30118,7 +29872,7 @@ EDITS: 2
(delete-samples 3 3)
(insert-samples 3 3 v1)
(let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
(snd-display "; 2 vals: ~A" vals))))
(undo 3)
(env-sound '(0 0 1 1))
@@ -30133,13 +29887,13 @@ EDITS: 2
(begin
(float-vector->channel v1 3 3)
(let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
(snd-display "; 4 vals (~A): ~A" dur vals))))
(begin
(fill! v1 0.0)
(float-vector->channel v1 4998 3)
(let ((vals (channel->float-vector 4995 10)))
- (if (not (vequal vals (float-vector 0.999 0.999 1.000 0.000 0.000 0.000 1.000 0.999 0.999 0.999)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.999 0.999 1.000 0.000 0.000 0.000 1.000 0.999 0.999 0.999)))
(snd-display "; 4 vals big: ~A" vals))))))
(undo 2)
(when (= dur 10)
@@ -30148,28 +29902,28 @@ EDITS: 2
(delete-samples 3 3)
(insert-samples 3 3 v1)
(let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 .2 .4 1 1 1 .75 .5 .25 0)))
(snd-display "; 2 vals: ~A" vals))))
(undo 3)
(env-sound '(0 0 1 1 2 0))
(let ((v1 (make-float-vector 3 1.0)))
(float-vector->channel v1 0 3)
(let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 1.000 1.000 1.000 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 1.000 1.000 1.000 0.600 0.800 1.000 0.750 0.500 0.250 0.000)))
(snd-display "; 4 vals: ~A" vals))))
(undo 2)
(env-sound '(0 0 1 1 2 0))
(let ((v1 (make-float-vector 3 1.0)))
(float-vector->channel v1 7 3)
(let ((vals (channel->float-vector 0 10)))
- (if (not (vequal vals (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 1.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.200 0.400 0.600 0.800 1.000 0.750 1.000 1.000 1.000)))
(snd-display "; 5 vals: ~A" vals))))
(undo 2))
(let ((file (file-name i1)))
(close-sound i1)
(if (file-exists? file) (delete-file file)))
))
- (list 10 10000))
+ '(10 10000))
(let ((ind (new-sound "fmv.snd" 1 22050 mus-ldouble mus-next "envd edit trees"))
(vals (make-float-vector 10000)))
@@ -30328,8 +30082,7 @@ EDITS: 2
(ramp-channel 0.1 0.4) ; val * (0.1 + (20000/50828)*0.3)
(let* ((val (sample 20000))
(ratio (/ 20000.0 50828))
- (val1 (+ 0.5 (* 0.5 ratio)))
- (val2 (* val1 0.5 ratio))
+ (val2 (* (+ 0.5 (* 0.5 ratio)) 0.5 ratio))
(val3 (* val2 (+ 0.1 (* ratio 0.3)))))
(if (fneq val val3)
(snd-display ";ramp-channels piled up (2): ~A ~A" val val3)))
@@ -30391,7 +30144,7 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i dur))
(float-vector-set! v1 i (r))))
- (if (not (vequal v0 v1))
+ (if (not (mus-arrays-equal? v0 v1))
(snd-display ";~A env check: ~A ~A" name v0 v1))))
(check-env (format #f "~A-1-0" name) (r-maker i1 0) (e-maker i1 0))
(check-env (format #f "~A-2-0" name) (r-maker i2 0) (e-maker i2 0))
@@ -30432,20 +30185,20 @@ EDITS: 2
(float-vector->channel v1 3 3 i2 0)
(float-vector->channel v1 3 3 i2 1)
(let ((vals (channel->float-vector 0 10 i1 0)))
- (if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
(snd-display "; 1 0 vals: ~A" vals))
(set! vals (channel->float-vector 0 10 i2 0))
- (if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
(snd-display "; 2 0 vals: ~A" vals))
(set! vals (channel->float-vector 0 10 i2 1))
- (if (not (vequal vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 (/ 1.111 dur) (/ 2.222 dur) 1 1 1 (/ 6.66 dur) (/ 7.77 dur) (/ 8.88 dur) (/ 10.0 dur))))
(snd-display "; 2 1 vals: ~A" vals))))
(let ((file (file-name i1)))
(close-sound i1)
(if (file-exists? file) (delete-file file)))
(close-sound i2)
))
- (list 10 10000))
+ '(10 10000))
(if (null? (hook-functions initial-graph-hook))
(begin
@@ -30483,12 +30236,11 @@ EDITS: 2
(list "1a.snd" "oboe.snd" "storm.snd" (if (file-exists? away) away "lola.snd"))))))
(snd-display "; scl rev env map scn pad wrt clm mix src del")
- (snd-display ";1a: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (car data)))
- (snd-display ";oboe: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (cdar data)))
- (snd-display ";storm:~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (caddr data)))
+ (snd-display ";1a: ~{~A ~}" (map (lambda (a) (if (< a .005) (copy " 0.0") (format #f "~6,2F" a))) (car data)))
+ (snd-display ";oboe: ~{~A ~}" (map (lambda (a) (if (< a .005) (copy " 0.0") (format #f "~6,2F" a))) (cdar data)))
+ (snd-display ";storm:~{~A ~}" (map (lambda (a) (if (< a .005) (copy " 0.0") (format #f "~6,2F" a))) (caddr data)))
(if (pair? (cadddr data))
- (snd-display ";away: ~{~A ~}" (map (lambda (a) (if (< a .005) " 0.0" (format #f "~6,2F" a))) (cadddr data))))
- )
+ (snd-display ";away: ~{~A ~}" (map (lambda (a) (if (< a .005) (copy " 0.0") (format #f "~6,2F" a))) (cadddr data)))))
(when (and all-args with-big-file)
(let ((ind (view-sound big-file-name)))
@@ -30567,7 +30319,7 @@ EDITS: 2
(snd-display ";bigger set tree: ~A" (edit-tree)))
(let ((new-vals (channel->float-vector (- (* (floor *clm-srate*) 50000) 50) 200)))
(do ((i 50 (+ i 1))) ((= i 150)) (set! (old-vals i) 1.0))
- (if (not (vequal new-vals old-vals)) (snd-display ";bigger set ~A ~A" old-vals new-vals))))
+ (if (not (mus-arrays-equal? new-vals old-vals)) (snd-display ";bigger set ~A ~A" old-vals new-vals))))
(env-channel (make-env '(0 0 1 1) :length (* (floor *clm-srate*) 60000)) 1000 (* (floor *clm-srate*) 60000))
(if (not (fieql (edit-tree) (list (list 0 0 0 999 0.5 0.0 0.0 0)
(list 1000 0 1000 2204999999 0.5 1.12130420080871e-17 0.83333295583725 1)
@@ -30589,12 +30341,12 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (read-sample r)))
- (if (not (vequal v (float-vector -0.021 -0.020 -0.020 -0.019 -0.018 -0.017 -0.016 -0.016 -0.015 -0.014)))
+ (if (not (mus-arrays-equal? v (float-vector -0.021 -0.020 -0.020 -0.019 -0.018 -0.017 -0.016 -0.016 -0.015 -0.014)))
(snd-display ";bigger short env vals: ~A" v)))
(revert-sound)
(let ((v (channel->float-vector (+ 75 (* (floor *clm-srate*) 50000)) 10)))
- (if (not (vequal v (float-vector -0.042 -0.043 -0.044 -0.045 -0.045 -0.045 -0.045 -0.045 -0.045 -0.046)))
+ (if (not (mus-arrays-equal? v (float-vector -0.042 -0.043 -0.044 -0.045 -0.045 -0.045 -0.045 -0.045 -0.045 -0.046)))
(snd-display ";bigger no env vals: ~A" v)))
(scale-to 1.0)
(if (fneq (maxamp) 1.0) (snd-display ";bigger scale-to 1.0 maxamp: ~A" (maxamp)))
@@ -30664,7 +30416,7 @@ EDITS: 2
(let* ((flt (make-one-zero 0.5 0.5))
(lvals (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10 ind 0 0)))
- (if (not (vequal lvals (float-vector -0.006 0.052 0.103 0.146 0.182 0.210 0.232 0.249 0.262 0.272)))
+ (if (not (mus-arrays-equal? lvals (float-vector -0.006 0.052 0.103 0.146 0.182 0.210 0.232 0.249 0.262 0.272)))
(snd-display ";bigger (orig) vals: ~A" lvals))
(clm-channel flt (+ (* (floor *clm-srate*) 65000) 1000) 10)
(if (not (fieql (edit-tree) (list (list 0 0 0 2204999999 1.0 0.0 0.0 0)
@@ -30675,7 +30427,7 @@ EDITS: 2
(list 2866500010 0 2866499910 (- big-file-framples 1) 1.0 0.0 0.0 0)
(list (+ big-file-framples 100) -2 0 0 0.0 0.0 0.0 0))))
(snd-display ";bigger clm: ~A" (edit-tree)))
- (if (not (vequal (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)
+ (if (not (mus-arrays-equal? (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)
(float-vector -0.006 0.015 0.065 0.107 0.142 0.169 0.190 0.205 0.216 0.222)))
(snd-display ";bigger clm vals: ~A" (channel->float-vector (+ 1000 (* (floor *clm-srate*) 65000)) 10)))
@@ -30684,11 +30436,11 @@ EDITS: 2
(do ((i 0 (+ i 1)))
((= i 10))
(set! (v i) (readin r)))
- (if (not (vequal v lvals))
+ (if (not (mus-arrays-equal? v lvals))
(snd-display ";bigger (orig) readin vals: ~A (~A)" v lvals))))
(revert-sound)
(let ((found (scan-channel (lambda (y) (> y .5)) (* (floor *clm-srate*) 50000))))
- (if (not (equal? found (list #t 2205000925)))
+ (if (not (equal? found '(#t 2205000925)))
(snd-display ";bigger scan: ~A" found)))
(set! (squelch-update) #f)
(close-sound ind))))
@@ -30703,7 +30455,7 @@ EDITS: 2
(let ((mx (maxamp ind 0)))
(if (fneq mx 0.5) (snd-display ";src-channel max .5: ~A" mx)))
(if (fneq (sample 200) 0.5) (snd-display ";src-channel 0.5 200: ~A" (sample 200)))
- (if (not (vequal (channel->float-vector 180 40 ind 0)
+ (if (not (mus-arrays-equal? (channel->float-vector 180 40 ind 0)
(float-vector 0.000 -0.000 0.000 0.001 -0.000 -0.003 0.000 0.007 -0.000 -0.012
0.000 0.020 -0.000 -0.033 0.000 0.054 -0.000 -0.100 -0.000 0.316
0.500 0.316 -0.000 -0.100 -0.000 0.054 0.000 -0.033 -0.000 0.020
@@ -30714,7 +30466,7 @@ EDITS: 2
(let ((mx (maxamp ind 0)))
(if (fneq mx 0.5) (snd-display ";src-channel max .25: ~A" mx)))
(if (fneq (sample 400) 0.5) (snd-display ";src-channel 0.25 400: ~A" (sample 400)))
- (if (not (vequal (channel->float-vector 360 80 ind 0)
+ (if (not (mus-arrays-equal? (channel->float-vector 360 80 ind 0)
(float-vector 0.000 -0.000 -0.000 -0.000 0.000 0.000 0.001 0.001 -0.000 -0.002
-0.003 -0.003 0.000 0.004 0.007 0.006 -0.000 -0.008 -0.012 -0.010
0.000 0.013 0.020 0.016 -0.000 -0.021 -0.033 -0.026 0.000 0.034
@@ -30751,8 +30503,8 @@ EDITS: 2
(if (> (abs (- s1 s2)) df) (snd-display ";sample ~D src(~A): ~A ~A" i sr s1 s2))
(if (fneq s3 0.0) (snd-display ";sample ~D (1): ~A" i s3))))
(undo 1 ind 0))
- (list 2.0 1.5 3.0 3.14)
- (list 0.008 0.01 0.015 0.025))
+ '(2.0 1.5 3.0 3.14)
+ '(0.008 0.01 0.015 0.025))
(close-sound ind)
(set! ind (open-sound "oboe.snd"))
(let ((orig-max (maxamp ind 0)))
@@ -30772,8 +30524,8 @@ EDITS: 2
((= j sri))
(r1))))))
(undo 1 ind 0))
- (list 2.0 1.5 3.0 3.14)
- (list 0.008 0.01 0.015 0.025))
+ '(2.0 1.5 3.0 3.14)
+ '(0.008 0.01 0.015 0.025))
(for-each
(lambda (sr df)
@@ -30787,8 +30539,8 @@ EDITS: 2
(if (> (abs (- s1 s2)) df) (snd-display ";sample ~D oboe src(~A): ~A ~A" i sr s1 s2))))
(undo 1 ind 0)
(amp-envs-equal? ind 0 (edit-position) (+ 1 (edit-position)) .01))
- (list 0.5 0.25 0.9 0.1)
- (list 0.001 0.001 0.001 0.001)))
+ '(0.5 0.25 0.9 0.1)
+ '(0.001 0.001 0.001 0.001)))
(revert-sound ind)
(scale-by 2.0)
(scale-by 0.5)
@@ -30806,7 +30558,7 @@ EDITS: 2
(let ((hi (make-float-vector 3)))
(fill-float-vector hi (if (scan-channel (lambda (y) (> y .1)))
1.0 0.0))
- (if (not (vequal hi (float-vector 1.0 1.0 1.0))) (snd-display ";fill-float-vector with scan-channel (opt ~A): ~A" n hi)))
+ (if (not (mus-arrays-equal? hi (float-vector 1.0 1.0 1.0))) (snd-display ";fill-float-vector with scan-channel (opt ~A): ~A" n hi)))
(let ((val (scan-channel (lambda (y) (scan-channel (lambda (n6) (> n6 .1)))))))
(if (not (= val 0)) (snd-display ";find with find: ~A" val)))
(let ((val (scan-channel (lambda (y) (scan-channel (lambda (n7) (> n7 .1)))))))
@@ -30827,7 +30579,7 @@ EDITS: 2
(if (not (= (edit-position ind 0) 2)) (snd-display ";map+map edit-pos: ~A" (edit-position ind 0)))
(if (fneq mx (/ (maxamp ind 0 1) 2)) (snd-display ";map+map max 1: ~A ~A" mx (maxamp ind 0 1))))
(revert-sound ind))
- (list 0 5))
+ '(0 5))
(close-sound ind))
(let ((ind (open-sound "oboe.snd")))
@@ -30846,9 +30598,9 @@ EDITS: 2
pad-channel
(lambda (beg dur) (src-channel 0.5 beg dur))
insert-silence)
- (list 0 0 0 0 0 0 0 0 0)
- (list 1000 1000 1000 1000 1000 1000 1000 1000 1000)
- (list 50828 50828 50828 50828 50828 50828 51828 52829 53829))
+ '(0 0 0 0 0 0 0 0 0)
+ '(1000 1000 1000 1000 1000 1000 1000 1000 1000)
+ '(50828 50828 50828 50828 50828 50828 51828 52829 53829))
(revert-sound ind)
@@ -30858,9 +30610,9 @@ EDITS: 2
(pad-channel beg dur)
(if (not (= (framples ind) len))
(snd-display ";(pad-channel ~A ~A) with ~A -> ~A (~A)?" beg dur old-len (framples ind) len))))
- (list 1000 60000 0 62000 62000 62004)
- (list 1000 1000 1000 1 2 1)
- (list 51828 61000 62000 62001 62003 62005))
+ '(1000 60000 0 62000 62000 62004)
+ '(1000 1000 1000 1 2 1)
+ '(51828 61000 62000 62001 62003 62005))
(revert-sound ind)
@@ -30881,8 +30633,8 @@ EDITS: 2
insert-silence
(lambda (beg dur) (env-sound '(0 0 1 1) beg dur))
)
- (list 1000 1000 1000 1000 1000 1000 1000 1000 1000 1000)
- (list 50828 50828 50828 50828 51928 51928 53028 53028 54028 54028))
+ '(1000 1000 1000 1000 1000 1000 1000 1000 1000 1000)
+ '(50828 50828 50828 50828 51928 51928 53028 53028 54028 54028))
(revert-sound ind)
@@ -31560,12 +31312,8 @@ EDITS: 1
(max 1 (+ (hundred (- mid-time-2 start-time-2)) (hundred (- end-time-2 mid-time-2))))))
(* 1.0 (/ (+ (hundred (- mid-time-1 start-time-1)) (hundred (- end-time-1 mid-time-1)))
(max 1 (+ (hundred (- mid-time start-time)) (hundred (- end-time mid-time)))))))))))))))))
-
- (list "scale" "set!" "env" "env-exp" "env-step" "delete" "insert" "pad"
- "mix-no-tag" "mix-tag" "mix-amp" "mix-scale" "src-2" "src"
- "filter" "filter-sym" "f10" "f10sym" "clm"
- "reverse"
- )
+ '("scale" "set!" "env" "env-exp" "env-step" "delete" "insert" "pad" "mix-no-tag" "mix-tag" "mix-amp"
+ "mix-scale" "src-2" "src" "filter" "filter-sym" "f10" "f10sym" "clm" "reverse")
(list
(lambda (snd i)
(scale-channel (* i .01)))
@@ -31681,7 +31429,7 @@ EDITS: 1
(src-channel 1.0 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if (and diff (> (car diff) .0001)) (snd-display ";edpos src 1 diff: ~A" diff)))
+ (if (and (pair? diff) (> (car diff) .0001)) (snd-display ";edpos src 1 diff: ~A" diff)))
(if (= (edit-position ind 0) (+ edpos 2))
(snd-display ";edpos src copy opted out?")
(undo))
@@ -31721,7 +31469,7 @@ EDITS: 1
(src-channel 1.0 0 #f ind 0 edpos)
(let ((diff (edit-difference ind 0 edpos (edit-position ind 0))))
- (if (and diff (> (car diff) .0001)) (snd-display ";1 edpos src 1 diff: ~A" diff)))
+ (if (and (pair? diff) (> (car diff) .0001)) (snd-display ";1 edpos src 1 diff: ~A" diff)))
(if (> (abs (- (framples ind 0) len)) 2)
(snd-display ";src len edpos: ~A ~A" len (framples ind 0)))
(undo)
@@ -31768,7 +31516,7 @@ EDITS: 1
(if (fneq (maxamp ind 0) .09) (snd-display ";del edpos max: ~A" (maxamp ind 0)))
(undo)
- (set! (samples 5 5 ind 0 #f "set" 0 edpos) (make-float-vector 5 0.0))
+ (set! (samples 5 5 ind 0 #f "set" 0 edpos) (make-float-vector 5))
(if (not (= (framples ind 0) 10)) (snd-display ";set edpos len: ~A" (framples ind 0)))
(if (fneq (maxamp ind 0) .04) (snd-display ";set edpos max: ~A" (maxamp ind 0)))
(undo)
@@ -31824,12 +31572,12 @@ EDITS: 1
(undo)
(float-vector->channel (make-float-vector 5 0.5) 15 5 ind 0 edpos)
(if (not (= (framples ind 0) 20)) (snd-display ";delete-samples edpos len: ~A" (framples ind 0)))
- (if (not (vequal (channel->float-vector 10 10) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 1.0 1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 0.5)))
(snd-display ";set samples edpos: ~A" (channel->float-vector 10 10)))
(undo)
(env-channel '(0 0 1 1) 0 #f ind 0 edpos)
(if (not (= (framples ind 0) 20)) (snd-display ";env edpos len: ~A" (framples ind 0)))
- (if (not (vequal (channel->float-vector 0 20) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474 0.526 0.579 0.632 0.684 0.737 0.789 0.842 0.895 0.947 1.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 20) (float-vector 0.000 0.053 0.105 0.158 0.211 0.263 0.316 0.368 0.421 0.474 0.526 0.579 0.632 0.684 0.737 0.789 0.842 0.895 0.947 1.000)))
(snd-display ";env edpos: ~A" (channel->float-vector 0 20)))
(undo)
(close-sound ind)))
@@ -31844,7 +31592,7 @@ EDITS: 1
(let ((v (convolve-coeffs (float-vector 1.0 0.5) (float-vector 1.0 0.5))))
(filter-channel v)
(let ((vdata (channel->float-vector 0 20)))
- (if (not (vequal data vdata))
+ (if (not (mus-arrays-equal? data vdata))
(snd-display ";filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
(undo)))
(let ((v1 (make-float-vector 8))
@@ -31858,7 +31606,7 @@ EDITS: 1
(let ((v (convolve-coeffs v1 v2)))
(filter-channel v)
(let ((vdata (channel->float-vector 0 20)))
- (if (not (vequal data vdata))
+ (if (not (mus-arrays-equal? data vdata))
(snd-display ";random filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
(undo))))
(let ((v1 (make-float-vector 18))
@@ -31872,7 +31620,7 @@ EDITS: 1
(let ((v (convolve-coeffs v1 v2)))
(filter-channel v)
(let ((vdata (channel->float-vector 0 20)))
- (if (not (vequal data vdata))
+ (if (not (mus-arrays-equal? data vdata))
(snd-display ";big random filter convolved: ~% standard: ~A~% virtual: ~A~%" data vdata)))
(undo))))
(close-sound ind))
@@ -31900,7 +31648,7 @@ EDITS: 1
(let ((dis (edit-distance ind 0 3 4)))
(if (> dis .2) (snd-display ";src-channel ~A, distance: ~A" rate dis)))
(undo 2))
- (list 2.0 -2.0 0.5 -0.5 1.5 -1.5 3.0 -3.0 0.2 -0.2))
+ '(2.0 -2.0 0.5 -0.5 1.5 -1.5 3.0 -3.0 0.2 -0.2))
(src-sound -1.001)
@@ -31922,7 +31670,7 @@ EDITS: 1
(let ((dis (edit-distance ind 0 3 4)))
(if (> dis .2) (snd-display ";src-sound ~A, distance: ~A" rate dis)))
(undo 2))
- (list 2.0 -2.0 0.5 -0.5 1.5 -1.5 3.0 -3.0 0.2 -0.2))
+ '(2.0 -2.0 0.5 -0.5 1.5 -1.5 3.0 -3.0 0.2 -0.2))
(close-sound ind))
@@ -31934,7 +31682,7 @@ EDITS: 1
(make-selection 3 7) ; beg end just for confusion
(env-selection '(0 0.5 1 0.5))
(let ((data (channel->float-vector)))
- (if (not (vequal data (float-vector .4 .4 .4 .2 .2 .2 .2 .2 .4 .4)))
+ (if (not (mus-arrays-equal? data (float-vector .4 .4 .4 .2 .2 .2 .2 .2 .4 .4)))
(snd-display ";env-selection constant: ~A" data)))
(undo)
(let ((edpos (edit-position ind 0)))
@@ -31946,7 +31694,7 @@ EDITS: 1
(map-channel (lambda (y) (set! ctr (+ ctr 1)) (or (> ctr 3) (* y 2)))))
(if (not (= (framples ind 0) 3))
(snd-display ";map-channel -> #t at 3: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.8 0.8 0.8)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.8 0.8 0.8)))
(snd-display ";map-channel #t result: ~A" (channel->float-vector))))
(undo)
@@ -31954,15 +31702,15 @@ EDITS: 1
(map-channel (lambda (y) (set! ctr (+ ctr 1)) (if (= ctr 3) (make-float-vector 5 .1) (* y .5)))))
(if (not (= (framples ind 0) 14))
(snd-display ";map-channel -> float-vector at 3: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.200 0.200 0.200)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.200 0.200 0.100 0.100 0.100 0.100 0.100 0.200 0.200 0.200 0.200 0.200 0.200 0.200)))
(snd-display ";map-channel float-vector result: ~A" (channel->float-vector))))
(undo)
- (let ((data (make-float-vector 2 0.0)))
+ (let ((data (make-float-vector 2)))
(map-channel (lambda (y) (float-vector-set! data 0 y) data)))
(if (not (= (framples ind 0) 20))
(snd-display ";map-channel -> float-vector: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000 0.400 0.000)))
(snd-display ";map-channel float-vector result: ~A" (channel->float-vector))))
(undo)
@@ -31972,7 +31720,7 @@ EDITS: 1
(undo)
(set! (amp-control ind) 2.0)
(apply-controls ind 1 5)
- (if (not (vequal (channel->float-vector 0 5) (float-vector 0.4 0.4 0.4 0.4 0.4)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 5) (float-vector 0.4 0.4 0.4 0.4 0.4)))
(snd-display ";apply controls from 5: ~A" (channel->float-vector)))
(if (ffneq (sample 5) .8) (snd-display ";apply-controls at 5: ~A" (sample 5)))
(let ((tag (catch 'no-such-edit
@@ -31994,7 +31742,7 @@ EDITS: 1
(map-channel (lambda (y) (or (> (set! ctr (+ ctr 1)) 3) (* y 2)))))
(if (not (= (framples ind 0) 3))
(snd-display ";map-channel oboe -> #t at 3: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector) (float-vector 0.0 -.001 -.001)))
+ (if (not (mus-arrays-equal? (channel->float-vector) (float-vector 0.0 -.001 -.001)))
(snd-display ";map-channel #t oboe result: ~A" (channel->float-vector))))
(undo)
@@ -32002,15 +31750,15 @@ EDITS: 1
(map-channel (lambda (y) (if (= (set! ctr (+ ctr 1)) 3) (make-float-vector 5 .1) (* y .5)))))
(if (not (= (framples ind 0) 50832))
(snd-display ";map-channel oboe -> float-vector at 3: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0.000 -0.000 0.100 0.100 0.100 0.100 0.100 -0.000 -0.000 -0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (float-vector 0.000 -0.000 0.100 0.100 0.100 0.100 0.100 -0.000 -0.000 -0.000)))
(snd-display ";map-channel float-vector result: ~A" (channel->float-vector 0 10))))
(undo)
- (let ((data (make-float-vector 2 0.0)))
+ (let ((data (make-float-vector 2)))
(map-channel (lambda (y) (set! (data 0) y) data)))
(if (not (= (framples ind 0) 101656))
(snd-display ";map-channel oboe -> float-vector: ~A" (framples ind 0))
- (if (not (vequal (channel->float-vector 0 10) (float-vector 0.000 0.000 -0.000 0.000 -0.000 0.000 -0.000 0.000 -0.000 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10) (float-vector 0.000 0.000 -0.000 0.000 -0.000 0.000 -0.000 0.000 -0.000 0.0)))
(snd-display ";map-channel float-vector result: ~A" (channel->float-vector 0 10))))
(revert-sound)
(close-sound ind))
@@ -32072,14 +31820,13 @@ EDITS: 1
(close-sound ind)
(close-sound ind1)))
- (let ((old-width *sinc-width*))
- (set! *sinc-width* 10)
+ (let-temporarily ((*sinc-width* 10))
(let ((res (new-sound :size 10)))
(set! (sample 3) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector -0.05016523320247118 0.1581800948824515 0.1581800948824515
+ (if (not (vmus-arrays-equal? v (float-vector -0.05016523320247118 0.1581800948824515 0.1581800948824515
-0.05016523320247118 0.02716944826115516 -0.01652926966015632)))
(snd-display ";src 2, 10 3 10: ~A" v)))
(close-sound res))
@@ -32088,7 +31835,7 @@ EDITS: 1
(set! (sample 2) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 0.25 0.0 0.0 0.0 0.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 0.25 0.0 0.0 0.0 0.0)))
(snd-display ";src 2, 10 2 10: ~A" v)))
(close-sound res))
@@ -32096,7 +31843,7 @@ EDITS: 1
(set! (sample 0) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";src 2, 10 0 10: ~A" v)))
(close-sound res))
@@ -32104,7 +31851,7 @@ EDITS: 1
(set! (sample 3) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector -0.05016523320247118 0.1581800948824515 0.1581800948824515
+ (if (not (vmus-arrays-equal? v (float-vector -0.05016523320247118 0.1581800948824515 0.1581800948824515
-0.05016523320247118 0.02716944826115516 -0.01652926966015632 0.01022512563738671)))
(snd-display ";src 2, 11 3 10: ~A" v)))
(close-sound res))
@@ -32113,7 +31860,7 @@ EDITS: 1
(set! (sample 2) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 0.25 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 0.25 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";src 2, 11 2 10: ~A" v)))
(close-sound res))
@@ -32121,7 +31868,7 @@ EDITS: 1
(set! (sample 0) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";src 2, 11 0 10: ~A" v)))
(close-sound res))
@@ -32132,7 +31879,7 @@ EDITS: 1
(set! (sample (- 39 i)) (* i .05)))
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.01198528796961999 0.1035793306415383 0.2059748594814547 0.3060708098272395 0.4072307780331241
+ (if (not (vmus-arrays-equal? v (float-vector 0.01198528796961999 0.1035793306415383 0.2059748594814547 0.3060708098272395 0.4072307780331241
0.5077603318367317 0.6062448605128621 0.7086656575233007 0.8045885470214085 0.9128440616541418
0.9536620711423869 0.8562080426776515 0.7579855746854125 0.6566287955350736 0.5575138524566664
0.4569842986530586 0.3574772574131896 0.2546643622412894 0.1572853567216201 0.04987330456145658 -0.0009027286222166014)))
@@ -32145,7 +31892,7 @@ EDITS: 1
(set! (sample 3) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector -0.05103248958541851 0.1584755057631961 0.1584755057631961
+ (if (not (vmus-arrays-equal? v (float-vector -0.05103248958541851 0.1584755057631961 0.1584755057631961
-0.05103248958541851 0.02854464095499105 -0.01828991864619797 0.01222560572178551 -0.008180460967128276 0.0)))
(snd-display ";src 2, 15 3 11: ~A" v)))
(close-sound res))
@@ -32154,21 +31901,17 @@ EDITS: 1
(set! (sample 0) .5)
(src-channel 2.0)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (vmus-arrays-equal? v (float-vector 0.25 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";src 2, 15 0 11: ~A" v)))
- (close-sound res))
-
- (set! *sinc-width* old-width))
-
+ (close-sound res)))
- (let ((old-width *sinc-width*))
- (set! *sinc-width* 10)
+ (let-temporarily ((*sinc-width* 10))
(let ((res (new-sound :size 10)))
(set! (sample 3) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 0.05433889652231032 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 0.05433889652231032 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5
0.316360189764903 0.0 -0.1003304664049424 0.0 0.05433889652231032 0.0 -0.03305853932031265 0.0
0.02045025127477342 0.0 -0.01220523861007159 0.0 0.006688908032246622 0.0)))
(format *stderr* "src 1/2, 10 3 10: ~A~%" v)))
@@ -32178,7 +31921,7 @@ EDITS: 1
(set! (sample 2) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5 0.316360189764903 0.0 -0.1003304664049424
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5 0.316360189764903 0.0 -0.1003304664049424
0.0 0.05433889652231032 0.0 -0.03305853932031265 0.0 0.02045025127477342 0.0
-0.01220523861007159 0.0 0.006688908032246622 0.0 -0.003110640428161881 0.0)))
(format *stderr* "src 1/2, 10 2 10: ~A~%" v)))
@@ -32188,7 +31931,7 @@ EDITS: 1
(set! (sample 0) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.5 0.316360189764903 0.0 -0.1003304664049424 0.0 0.05433889652231032 0.0 -0.03305853932031265
+ (if (not (vmus-arrays-equal? v (float-vector 0.5 0.316360189764903 0.0 -0.1003304664049424 0.0 0.05433889652231032 0.0 -0.03305853932031265
0.0 0.02045025127477342 0.0 -0.01220523861007159 0.0 0.006688908032246622 0.0
-0.003110640428161881 0.0 0.001022072692939124 0.0 -0.000103644775079492 0.0)))
(format *stderr* "src 1/2, 10 0 10: ~A~%" v)))
@@ -32199,7 +31942,7 @@ EDITS: 1
(set! (sample 3) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 0.05433889652231032 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5 0.316360189764903
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 0.05433889652231032 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5 0.316360189764903
0.0 -0.1003304664049424 0.0 0.05433889652231032 0.0 -0.03305853932031265 0.0 0.02045025127477342
0.0 -0.01220523861007159 0.0 0.006688908032246622 0.0 -0.003110640428161881 0.0)))
(format *stderr* "src 1/2, 11 3 10: ~A~%" v)))
@@ -32209,7 +31952,7 @@ EDITS: 1
(set! (sample 2) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5 0.316360189764903 0.0 -0.1003304664049424
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 -0.1003304664049424 0.0 0.316360189764903 0.5 0.316360189764903 0.0 -0.1003304664049424
0.0 0.05433889652231032 0.0 -0.03305853932031265 0.0 0.02045025127477342 0.0 -0.01220523861007159
0.0 0.006688908032246622 0.0 -0.003110640428161881 0.0 0.001022072692939124 0.0)))
(format *stderr* "src 1/2, 11 2 10: ~A~%" v)))
@@ -32219,7 +31962,7 @@ EDITS: 1
(set! (sample 0) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.5 0.316360189764903 0.0 -0.1003304664049424 0.0 0.05433889652231032 0.0 -0.03305853932031265
+ (if (not (vmus-arrays-equal? v (float-vector 0.5 0.316360189764903 0.0 -0.1003304664049424 0.0 0.05433889652231032 0.0 -0.03305853932031265
0.0 0.02045025127477342 0.0 -0.01220523861007159 0.0 0.006688908032246622 0.0
-0.003110640428161881 0.0 0.001022072692939124 0.0 -0.000103644775079492 0.0 0.0 0.0)))
(format *stderr* "src 1/2, 11 0 10: ~A~%" v)))
@@ -32233,7 +31976,7 @@ EDITS: 1
(set! (sample (- 39 i)) (* i .05)))
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 0.02056010532402247 0.05 0.07720130317537323 0.1 0.1238094543862298 0.15 0.1758514952493174
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 0.02056010532402247 0.05 0.07720130317537323 0.1 0.1238094543862298 0.15 0.1758514952493174
0.2 0.2245876821803736 0.25 0.2753688942389073 0.3 0.3249295824364337 0.35 0.3751591614371849
0.4 0.4250776763951197 0.45 0.4750983986223486 0.5 0.5251191208495776 0.55 0.5750480002850203
0.6000000000000001 0.6251857364939857 0.65 0.6749656459425423 0.7000000000000001 0.7252971884488815
@@ -32254,7 +31997,7 @@ EDITS: 1
(set! (sample 3) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.0 0.05588873297652781 0.0 -0.1013169884822853 0.0 0.3166955736757819 0.5 0.3166955736757819
+ (if (not (vmus-arrays-equal? v (float-vector 0.0 0.05588873297652781 0.0 -0.1013169884822853 0.0 0.3166955736757819 0.5 0.3166955736757819
0.0 -0.1013169884822853 0.0 0.05588873297652781 0.0 -0.03503207135776369 0.0 0.02267085373675465
0.0 -0.01446863119016991 0.0 0.008794782253203336 0.0 -0.004875864375201019 0.0 0.002288656235197179
0.0 -0.0007570986863940245 0.0 7.729542250127452e-05 0.0 0.0 0.0)))
@@ -32265,7 +32008,7 @@ EDITS: 1
(set! (sample 0) .5)
(src-channel 0.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 0.5 0.3166955736757819 0.0 -0.1013169884822853 0.0 0.05588873297652781 0.0 -0.03503207135776369 0.0
+ (if (not (vmus-arrays-equal? v (float-vector 0.5 0.3166955736757819 0.0 -0.1013169884822853 0.0 0.05588873297652781 0.0 -0.03503207135776369 0.0
0.02267085373675465 0.0 -0.01446863119016991 0.0 0.008794782253203336 0.0 -0.004875864375201019 0.0
0.002288656235197179 0.0 -0.0007570986863940245 0.0 7.729542250127452e-05 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
(format *stderr* "src 1/2, 15 0 11: ~A~%" v)))
@@ -32277,7 +32020,7 @@ EDITS: 1
(set! (sample 2) .5)
(src-channel 1.5)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector -0.0659173000292574 0.2750218141864232 0.1361775290259087 -0.05140008051946586 0.02873817799080515
+ (if (not (vmus-arrays-equal? v (float-vector -0.0659173000292574 0.2750218141864232 0.1361775290259087 -0.05140008051946586 0.02873817799080515
-0.01761592377597271 0.01086818222156537 -0.006418849681280971)))
(format *stderr* "src 1.5, 10 0 10: ~A~%" v)))
(close-sound res))
@@ -32286,7 +32029,7 @@ EDITS: 1
(set! (sample 2) .5)
(src-channel 0.3)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector -2.309626927862667e-14 -0.07046687722856798 -0.1029821798386912 -0.04339187529883121
+ (if (not (vmus-arrays-equal? v (float-vector -2.309626927862667e-14 -0.07046687722856798 -0.1029821798386912 -0.04339187529883121
0.1151049838606023 0.316360189764903 0.4672831482919799 0.4916944808321784 0.3769307110649516
0.1817344234767786 1.953289539319582e-14 -0.09498013189693179 -0.08875244041152466
-0.0236470298331755 0.03764309466867966 0.05433889652231032 0.02735343920407904
@@ -32304,13 +32047,10 @@ EDITS: 1
(set! (sample 8) .5)
(src-channel e)
(let ((v (channel->float-vector)))
- (if (not (vvequal v (float-vector 3.511360236100833e-14 0.499999999999969 0.03245693012152732 -0.04426423670248926
+ (if (not (vmus-arrays-equal? v (float-vector 3.511360236100833e-14 0.499999999999969 0.03245693012152732 -0.04426423670248926
0.05693627592759216 -0.06869987735399859 0.1364034106143399 0.2654607053632132 -0.04771168369895742)))
(format *stderr* "src e, 10 0 10: ~A~%" v)))
- (close-sound res))
-
- (set! *sinc-width* old-width))
-
+ (close-sound res)))
(let ((ind (new-sound "test.snd" :size 40000)))
(let ((gen (make-triangle-wave 10.0 0.5)))
@@ -32341,26 +32081,6 @@ EDITS: 1
(define (snd_test_17)
- (define ->
- (let ((documentation "draw an arrow pointing (from the left) at the point (x0 y0)"))
- (lambda (x0 y0 size snd chn cr)
- (let ((points (make-vector 8)))
-
- (let ((x x0) (y y0))
- (define (point i x y)
- (set! (points (* i 2)) x)
- (set! (points (+ (* i 2) 1)) y))
- (point 0 x y)
- (point 1 (- x (* 2 size)) (- y size))
- (point 2 (- x (* 2 size)) (+ y size))
- (point 3 x y)
- (fill-polygon points snd chn time-graph cr))
-
- (fill-rectangle (- x0 (* 4 size))
- (floor (- y0 (* .4 size)))
- (* 2 size)
- (floor (* .8 size))
- snd chn time-graph #f cr)))))
(when with-gui
(require snd-musglyphs.scm)
(hook-push after-graph-hook (lambda (hook) (display-previous-edits (hook 'snd) (hook 'chn))))
@@ -32376,63 +32096,84 @@ EDITS: 1
(y->position .5 snd chn lisp-graph)
snd chn lisp-graph cr)
(free-cairo cr)))))))
- (let ((ind (open-sound "oboe.snd"))
- (wids (channel-widgets))
- (wids1 (channel-widgets (selected-sound)))
- (wids2 (channel-widgets (selected-sound) (selected-channel))))
- (do ((i 1 (+ i 1)))
- ((= i 4))
- (scale-by 0.5)
- (set! (x-bounds) (list 0 (* i .3))))
- (revert-sound ind)
- (draw-bass-clef 100 100 100 0 ind 0)
- (update-time-graph ind 0)
- (draw-fermata 200 100 60 0 ind 0)
- (let ((cr (make-cairo (car (channel-widgets ind 0)))))
- (draw-line 100 100 200 200 ind 0 time-graph cr)
- (draw-dot 300 300 10 ind 0 time-graph cr)
- (draw-string "hiho" 20 20 ind 0 time-graph cr)
- (draw-dots #(25 25 50 50 100 100) 10 ind 0 time-graph cr)
- (-> 100 50 10 ind 0 cr)
- (fill-rectangle 20 20 100 100 ind 0 time-graph #f cr)
- (free-cairo cr))
- (make-bezier 0 0 20 20 40 30 60 10 10)
- (update-time-graph ind 0)
+
+ (let ((->
+ (let ((documentation "draw an arrow pointing (from the left) at the point (x0 y0)"))
+ (lambda (x0 y0 size snd chn cr)
+ (let ((points (make-vector 8)))
+
+ (let ((x x0) (y y0))
+ (define (point i x y)
+ (set! (points (* i 2)) x)
+ (set! (points (+ (* i 2) 1)) y))
+ (point 0 x y)
+ (point 1 (- x (* 2 size)) (- y size))
+ (point 2 (- x (* 2 size)) (+ y size))
+ (point 3 x y)
+ (fill-polygon points snd chn time-graph cr))
+
+ (fill-rectangle (- x0 (* 4 size))
+ (floor (- y0 (* .4 size)))
+ (* 2 size)
+ (floor (* .8 size))
+ snd chn time-graph #f cr))))))
+ (let ((ind (open-sound "oboe.snd"))
+ (wids (channel-widgets))
+ (wids1 (channel-widgets (selected-sound)))
+ (wids2 (channel-widgets (selected-sound) (selected-channel))))
+ (do ((i 1 (+ i 1)))
+ ((= i 4))
+ (scale-by 0.5)
+ (set! (x-bounds) (list 0 (* i .3))))
+ (revert-sound ind)
+ (draw-bass-clef 100 100 100 0 ind 0)
+ (update-time-graph ind 0)
+ (draw-fermata 200 100 60 0 ind 0)
+ (let ((cr (make-cairo (car (channel-widgets ind 0)))))
+ (draw-line 100 100 200 200 ind 0 time-graph cr)
+ (draw-dot 300 300 10 ind 0 time-graph cr)
+ (draw-string "hiho" 20 20 ind 0 time-graph cr)
+ (draw-dots #(25 25 50 50 100 100) 10 ind 0 time-graph cr)
+ (-> 100 50 10 ind 0 cr)
+ (fill-rectangle 20 20 100 100 ind 0 time-graph #f cr)
+ (free-cairo cr))
+ (make-bezier 0 0 20 20 40 30 60 10 10)
+ (update-time-graph ind 0)
;(fill-rectangle 20 20 100 100 ind 0 time-graph #t)
- (set! (hook-functions after-graph-hook) ())
- (set! (hook-functions lisp-graph-hook) ())
-
- (set! (hook-functions lisp-graph-hook) ())
- (let ((ind (open-sound "oboe.snd")))
- (set! (time-graph? ind 0) #f)
- (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
- (update-lisp-graph)
- (hook-push lisp-graph-hook (lambda (hook)
- (set! (hook 'result) (list *basic-color* *zoom-color* *data-color* *selected-data-color* *mix-color*))))
- (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
- (update-lisp-graph)
+ (set! (hook-functions after-graph-hook) ())
(set! (hook-functions lisp-graph-hook) ())
- (close-sound ind))
-
- (let ((ind1 (open-sound "2.snd")))
- (let ((wids3 (channel-widgets ind1 0))
- (wids4 (channel-widgets ind1 1)))
- (if (or (not (pair? wids))
- (not (pair? wids3))
- (and (provided? 'snd-motif)
- (not (= (length wids1) 11 (length wids2)))))
- (snd-display ";channel-widgets confused: ~A ~A ~A ~A ~A" wids wids1 wids2 wids3 wids4)))
- (hide-widget (car (channel-widgets)))
- (show-widget (car (channel-widgets)))
- (close-sound ind1))
- (close-sound ind))
-
+
+ (set! (hook-functions lisp-graph-hook) ())
+ (let ((ind (open-sound "oboe.snd")))
+ (set! (time-graph? ind 0) #f)
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
+ (update-lisp-graph)
+ (hook-push lisp-graph-hook (lambda (hook)
+ (set! (hook 'result) (list *basic-color* *zoom-color* *data-color* *selected-data-color* *mix-color*))))
+ (graph (list (float-vector 0 1 2) (float-vector 3 2 1) (float-vector 1 2 3) (float-vector 1 1 1) (float-vector 0 1 0) (float-vector 3 1 2)))
+ (update-lisp-graph)
+ (set! (hook-functions lisp-graph-hook) ())
+ (close-sound ind))
+
+ (let ((ind1 (open-sound "2.snd")))
+ (let ((wids3 (channel-widgets ind1 0))
+ (wids4 (channel-widgets ind1 1)))
+ (if (or (not (pair? wids))
+ (not (pair? wids3))
+ (and (provided? 'snd-motif)
+ (not (= (length wids1) 11 (length wids2)))))
+ (snd-display ";channel-widgets confused: ~A ~A ~A ~A ~A" wids wids1 wids2 wids3 wids4)))
+ (hide-widget (car (channel-widgets)))
+ (show-widget (car (channel-widgets)))
+ (close-sound ind1))
+ (close-sound ind)))
+
(start-enveloping)
(let ((nind (open-sound "oboe.snd")))
- (if (not (equal? (channel-envelope nind 0) (list 0.0 1.0 1.0 1.0)))
+ (if (not (equal? (channel-envelope nind 0) '(0.0 1.0 1.0 1.0)))
(snd-display ";channel-envelope: ~A?" (channel-envelope nind 0)))
- (set! (channel-envelope nind 0) (list 0 0 1 1 2 0))
- (if (not (equal? (channel-envelope nind 0) (list 0 0 1 1 2 0)))
+ (set! (channel-envelope nind 0) '(0 0 1 1 2 0))
+ (if (not (equal? (channel-envelope nind 0) '(0 0 1 1 2 0)))
(snd-display ";set channel-envelope: ~A?" (channel-envelope nind 0)))
(close-sound nind)
(stop-enveloping)))
@@ -32557,8 +32298,7 @@ EDITS: 1
(ssb-bank old-freq new-freq 10))
(define (retime-sound new-time)
- (let* ((old-time (/ (framples) (srate)))
- (factor (/ new-time old-time)))
+ (let ((factor (/ (* new-time (srate)) (framples))))
(ssb-bank 557 (* 557 factor) 10)
(src-sound (/ 1.0 factor))))
@@ -32601,16 +32341,13 @@ EDITS: 1
(snd-display ";save mark: ~A?" (mark-sample (car (marks ind 0)))))
(if (not (= (edit-position ind 0) 1))
(snd-display ";save edit-position: ~A" (edit-position ind 0)))))
- (if (not (equal? (edit-fragment 1 ind 0) (list "delete-samples 12 1" "delete" 12 1)))
+ (if (not (equal? (edit-fragment 1 ind 0) '("delete-samples 12 1" "delete" 12 1)))
(snd-display ";save edits: ~A" (edit-fragment 1 ind 0)))
- (if (not (equal? (edit-tree ind 0)
- (list (list 0 0 0 11 1.0 0.0 0.0 0) (list 12 0 13 50827 1.0 0.0 0.0 0) (list 50827 -2 0 0 0.0 0.0 0.0 0))))
+ (if (not (equal? (edit-tree ind 0) '((0 0 0 11 1.0 0.0 0.0 0) (12 0 13 50827 1.0 0.0 0.0 0) (50827 -2 0 0 0.0 0.0 0.0 0))))
(snd-display ";save edit tree: ~A" (edit-tree ind 0)))
- (if (not (and (number? (sound-property 'ho ind))
- (= (sound-property 'ho ind) 1234)))
+ (if (not (eqv? (sound-property 'ho ind) 1234))
(snd-display ";sound-property saved: 1234 -> ~A" (sound-property 'ho ind)))
- (if (not (and (string? (sound-property :hi ind))
- (string=? (sound-property :hi ind) "hi")))
+ (if (not (equal? (sound-property :hi ind) "hi"))
(snd-display ";sound-property saved: hi -> ~A" (sound-property :hi ind)))
(if (or (not (number? (channel-property :ha ind 0)))
(fneq (channel-property :ha ind 0) 3.14))
@@ -32742,81 +32479,68 @@ EDITS: 1
(close-sound ind1)
(delete-file "t1.scm"))
- (let ((ind (open-sound "oboe.snd"))
- (old-save-dir *save-dir*)
- (old-eps-file *eps-file*))
- (set! *save-dir* #f)
- (let ((v (make-float-vector 32 1.0)))
- (set! (samples 100 32) v))
- (map-channel (lambda (y) (+ y .1)) 1000 10000)
- (set! (show-axes ind 0) show-no-axes)
- (set! *zoom-focus-style* zoom-focus-middle)
- (set! (transform-normalization ind 0) dont-normalize)
- (set! (graph-style ind 0) graph-filled)
- (set! (transform-graph-type ind 0) graph-as-spectrogram)
- (set! (time-graph-type ind 0) graph-as-wavogram)
- (set! (x-axis-style ind 0) x-axis-as-percentage)
- (set! (speed-control-style ind) speed-control-as-semitone)
- (set! (cursor ind 0) 1234)
- (set! *eps-file* "hiho.eps")
- (set! (amp-control-bounds ind) (list 0.0 2.5))
- (set! (speed-control-bounds ind) (list 1.0 2.5))
- (set! (reverb-control-scale-bounds ind) (list 0.0 2.5))
- (set! (reverb-control-length-bounds ind) (list 0.0 2.5))
- (set! (contrast-control-bounds ind) (list 0.0 2.5))
- (set! (x-axis-label ind 0 time-graph) "time-x")
- (set! (y-axis-label ind 0 time-graph) "amp-y")
- (let ((old-srate *clm-srate*)
- (old-file-buffer-size *clm-file-buffer-size*)
- (old-array-print-length *mus-array-print-length*)
- (old-clm-table-size *clm-table-size*))
- (set! *clm-srate* 48000)
- (set! *mus-array-print-length* 24)
- (set! *clm-file-buffer-size* 4096)
- (set! *clm-table-size* 256)
- (if (file-exists? "s61.scm") (delete-file "s61.scm"))
- (save-state "s61.scm")
- (close-sound ind)
- (for-each forget-region (regions))
- (load (string-append cwd "s61.scm"))
- (if (fneq *clm-srate* 48000.0) (snd-display ";save/restore mus-srate: ~A" *clm-srate*))
- (if (not (= *clm-file-buffer-size* 4096)) (snd-display ";save/restore mus-file-buffer-size: ~A" *clm-file-buffer-size*))
- (if (not (= *mus-array-print-length* 24)) (snd-display ";save/restore mus-array-print-length: ~A" *mus-array-print-length*))
- (if (not (= *clm-table-size* 256)) (snd-display ";save/restore clm-table-size: ~A" *clm-table-size*))
- (set! *clm-srate* old-srate)
- (set! *mus-array-print-length* old-array-print-length)
- (set! *clm-file-buffer-size* old-file-buffer-size)
- (set! *clm-table-size* old-clm-table-size))
- (set! *save-dir* old-save-dir)
- (set! ind (find-sound "oboe.snd"))
- (if (not (= (show-axes ind 0) show-no-axes)) (snd-display ";save show-no-axes: ~A" (show-axes ind 0)))
- (if (not (= *zoom-focus-style* zoom-focus-middle)) (snd-display ";save zoom-focus-middle: ~A" *zoom-focus-style*))
- (if (not (= (transform-normalization ind 0) dont-normalize)) (snd-display ";save dont-normalize: ~A" (transform-normalization ind 0)))
- (if (not (= (graph-style ind 0) graph-filled)) (snd-display ";save graph-filled: ~A" (graph-style ind 0)))
- (if (not (= (transform-graph-type ind 0) graph-as-spectrogram)) (snd-display ";save graph-as-spectrogram: ~A" (transform-graph-type ind 0)))
- (if (not (= (time-graph-type ind 0) graph-as-wavogram)) (snd-display ";save graph-as-wavogram: ~A" (time-graph-type ind 0)))
- (if (not (= (x-axis-style ind 0) x-axis-as-percentage)) (snd-display ";save x-axis-as-percentage: ~A" (x-axis-style ind 0)))
- (if (not (= (speed-control-style ind) speed-control-as-semitone)) (snd-display ";save speed-control-style: ~A" (speed-control-style ind)))
- (if (not (= (cursor ind 0) 1234)) (snd-display ";save cursor 1234: ~A" (cursor ind 0)))
- (if (not (string=? *eps-file* "hiho.eps")) (snd-display ";save eps-file: ~A" *eps-file*))
- (when with-gui
- (if (not (string=? (x-axis-label ind 0 time-graph) "time-x"))
- (snd-display ";save x-axis-label: ~A" (x-axis-label ind 0 time-graph)))
- (if (not (string=? (y-axis-label ind 0 time-graph) "amp-y"))
- (snd-display ";save y-axis-label: ~A" (y-axis-label ind 0 time-graph))))
- (if (not (feql (amp-control-bounds ind) (list 0 2.5)))
- (snd-display ";save amp-control-bounds: ~A" (amp-control-bounds ind)))
- (if (not (feql (speed-control-bounds ind) (list 1.0 2.5)))
- (snd-display ";save speed-control-bounds: ~A" (speed-control-bounds ind)))
- (if (not (feql (contrast-control-bounds ind) (list 0 2.5)))
- (snd-display ";save contrast-control-bounds: ~A" (contrast-control-bounds ind)))
- (if (not (feql (reverb-control-scale-bounds ind) (list 0 2.5)))
- (snd-display ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds ind)))
- (if (not (feql (reverb-control-length-bounds ind) (list 0 2.5)))
- (snd-display ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds ind)))
- (set! *eps-file* old-eps-file)
- (delete-file "s61.scm")
- (close-sound ind))
+ (let ((ind (open-sound "oboe.snd")))
+ (let-temporarily ((*eps-file* "hiho.eps")
+ (*save-dir* #f))
+ (set! (samples 100 32) (make-float-vector 32 1.0))
+ (map-channel (lambda (y) (+ y .1)) 1000 10000)
+ (set! (show-axes ind 0) show-no-axes)
+ (set! *zoom-focus-style* zoom-focus-middle)
+ (set! (transform-normalization ind 0) dont-normalize)
+ (set! (graph-style ind 0) graph-filled)
+ (set! (transform-graph-type ind 0) graph-as-spectrogram)
+ (set! (time-graph-type ind 0) graph-as-wavogram)
+ (set! (x-axis-style ind 0) x-axis-as-percentage)
+ (set! (speed-control-style ind) speed-control-as-semitone)
+ (set! (cursor ind 0) 1234)
+ (set! (amp-control-bounds ind) (list 0.0 2.5))
+ (set! (speed-control-bounds ind) (list 1.0 2.5))
+ (set! (reverb-control-scale-bounds ind) (list 0.0 2.5))
+ (set! (reverb-control-length-bounds ind) (list 0.0 2.5))
+ (set! (contrast-control-bounds ind) (list 0.0 2.5))
+ (set! (x-axis-label ind 0 time-graph) "time-x")
+ (set! (y-axis-label ind 0 time-graph) "amp-y")
+ (let-temporarily ((*clm-srate* 48000)
+ (*clm-file-buffer-size* 4096)
+ (*mus-array-print-length* 24)
+ (*clm-table-size* 256))
+ (if (file-exists? "s61.scm") (delete-file "s61.scm"))
+ (save-state "s61.scm")
+ (close-sound ind)
+ (for-each forget-region (regions))
+ (load (string-append cwd "s61.scm"))
+ (if (fneq *clm-srate* 48000.0) (snd-display ";save/restore mus-srate: ~A" *clm-srate*))
+ (if (not (= *clm-file-buffer-size* 4096)) (snd-display ";save/restore mus-file-buffer-size: ~A" *clm-file-buffer-size*))
+ (if (not (= *mus-array-print-length* 24)) (snd-display ";save/restore mus-array-print-length: ~A" *mus-array-print-length*))
+ (if (not (= *clm-table-size* 256)) (snd-display ";save/restore clm-table-size: ~A" *clm-table-size*)))
+ (set! ind (find-sound "oboe.snd"))
+ (if (not (= (show-axes ind 0) show-no-axes)) (snd-display ";save show-no-axes: ~A" (show-axes ind 0)))
+ (if (not (= *zoom-focus-style* zoom-focus-middle)) (snd-display ";save zoom-focus-middle: ~A" *zoom-focus-style*))
+ (if (not (= (transform-normalization ind 0) dont-normalize)) (snd-display ";save dont-normalize: ~A" (transform-normalization ind 0)))
+ (if (not (= (graph-style ind 0) graph-filled)) (snd-display ";save graph-filled: ~A" (graph-style ind 0)))
+ (if (not (= (transform-graph-type ind 0) graph-as-spectrogram)) (snd-display ";save graph-as-spectrogram: ~A" (transform-graph-type ind 0)))
+ (if (not (= (time-graph-type ind 0) graph-as-wavogram)) (snd-display ";save graph-as-wavogram: ~A" (time-graph-type ind 0)))
+ (if (not (= (x-axis-style ind 0) x-axis-as-percentage)) (snd-display ";save x-axis-as-percentage: ~A" (x-axis-style ind 0)))
+ (if (not (= (speed-control-style ind) speed-control-as-semitone)) (snd-display ";save speed-control-style: ~A" (speed-control-style ind)))
+ (if (not (= (cursor ind 0) 1234)) (snd-display ";save cursor 1234: ~A" (cursor ind 0)))
+ (if (not (string=? *eps-file* "hiho.eps")) (snd-display ";save eps-file: ~A" *eps-file*))
+ (when with-gui
+ (if (not (string=? (x-axis-label ind 0 time-graph) "time-x"))
+ (snd-display ";save x-axis-label: ~A" (x-axis-label ind 0 time-graph)))
+ (if (not (string=? (y-axis-label ind 0 time-graph) "amp-y"))
+ (snd-display ";save y-axis-label: ~A" (y-axis-label ind 0 time-graph))))
+ (if (not (feql (amp-control-bounds ind) '(0 2.5)))
+ (snd-display ";save amp-control-bounds: ~A" (amp-control-bounds ind)))
+ (if (not (feql (speed-control-bounds ind) '(1.0 2.5)))
+ (snd-display ";save speed-control-bounds: ~A" (speed-control-bounds ind)))
+ (if (not (feql (contrast-control-bounds ind) '(0 2.5)))
+ (snd-display ";save contrast-control-bounds: ~A" (contrast-control-bounds ind)))
+ (if (not (feql (reverb-control-scale-bounds ind) '(0 2.5)))
+ (snd-display ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds ind)))
+ (if (not (feql (reverb-control-length-bounds ind) '(0 2.5)))
+ (snd-display ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds ind)))
+ (delete-file "s61.scm")
+ (close-sound ind)))
(let ((ind (open-sound "oboe.snd"))
(old-tiny-font *tiny-font*)
@@ -32842,15 +32566,15 @@ EDITS: 1
(if (not (string=? *tiny-font* "8x13")) (snd-display ";save tiny-font: ~A" *tiny-font*))
(if (not (string=? *peaks-font* "8x13")) (snd-display ";save peaks-font: ~A" *peaks-font*))
(if (not (string=? *bold-peaks-font* "8x13")) (snd-display ";save bold-peaks-font: ~A" *bold-peaks-font*))
- (if (not (feql (amp-control-bounds) (list 0 2.5)))
+ (if (not (feql (amp-control-bounds) '(0 2.5)))
(snd-display ";save amp-control-bounds: ~A" (amp-control-bounds)))
- (if (not (feql (speed-control-bounds) (list 1.0 2.5)))
+ (if (not (feql (speed-control-bounds) '(1.0 2.5)))
(snd-display ";save speed-control-bounds: ~A" (speed-control-bounds)))
- (if (not (feql (contrast-control-bounds) (list 0 2.5)))
+ (if (not (feql (contrast-control-bounds) '(0 2.5)))
(snd-display ";save contrast-control-bounds: ~A" (contrast-control-bounds)))
- (if (not (feql (reverb-control-scale-bounds) (list 0 2.5)))
+ (if (not (feql (reverb-control-scale-bounds) '(0 2.5)))
(snd-display ";save reverb-control-scale-bounds: ~A" (reverb-control-scale-bounds)))
- (if (not (feql (reverb-control-length-bounds) (list 0 2.5)))
+ (if (not (feql (reverb-control-length-bounds) '(0 2.5)))
(snd-display ";save reverb-control-length-bounds: ~A" (reverb-control-length-bounds)))
(set! *tiny-font* old-tiny-font)
(set! *peaks-font* old-peaks-font)
@@ -33011,47 +32735,47 @@ EDITS: 1
(lambda (ind)
(if (not (= (framples ind 0) 105)) (snd-display ";pad sample save-state len: ~A" (framples ind 0)))
(if (not (= (edit-position ind 0) 2)) (snd-display ";pad sample save-state edpos: ~A" (edit-position ind 0)))
- (if (not (vequal (float-vector .5 .5 0 0 0 0 0 .5 .5 .5) (channel->float-vector 10 10 ind 0)))
+ (if (not (mus-arrays-equal? (float-vector .5 .5 0 0 0 0 0 .5 .5 .5) (channel->float-vector 10 10 ind 0)))
(snd-display ";pad sample save-state: ~A" (channel->float-vector 10 10 ind 0))))
(lambda (ind)
(if (not (= (framples ind 0) 100)) (snd-display ";env sample save-state len: ~A" (framples ind 0)))
(if (not (= (edit-position ind 0) 2)) (snd-display ";env sample save-state edpos: ~A" (edit-position ind 0)))
- (if (not (vequal (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 1.0 1.0 1.0 1.0) (channel->float-vector 0 15 ind 0)))
+ (if (not (mus-arrays-equal? (float-vector 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0 1.0 1.0 1.0 1.0) (channel->float-vector 0 15 ind 0)))
(snd-display ";env sample save-state: ~A" (channel->float-vector 0 15 ind 0))))
(lambda (ind)
(if (not (= (framples ind 0) 100)) (snd-display "; sample save-state len: ~A" (framples ind 0)))
(if (not (= (edit-position ind 0) 1)) (snd-display "; sample save-state edpos: ~A" (edit-position ind 0)))
(if (fneq (maxamp ind 0) .1) (snd-display "; save-state max: ~A" (maxamp ind 0)))
- (if (not (vequal (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display "; save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
+ (if (not (mus-arrays-equal? (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display "; save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
;; map-channel as backup
(lambda (ind)
(if (not (= (framples ind 0) 50)) (snd-display ";map #f save-state len: ~A" (framples ind 0)))
(if (not (= (edit-position ind 0) 1)) (snd-display ";map #f save-state edpos: ~A" (edit-position ind 0)))
(if (fneq (maxamp ind 0) .1) (snd-display ";map #f save-state max: ~A" (maxamp ind 0)))
- (if (not (vequal (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display ";map #f save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
+ (if (not (mus-arrays-equal? (make-float-vector 10 .1) (channel->float-vector 0 10))) (snd-display ";map #f save-state vals: ~A" (channel->float-vector 0 10 ind 0))))
;; as-one-edit
(lambda (ind)
(if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup 2 float-vectors edpos: ~A" (edit-position ind 0)))
- (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 0) (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0)))
(snd-display ";as-one-edit save-state 1: ~A" (channel->float-vector 0 10 ind 0)))
- (if (not (vequal (channel->float-vector 20 10 ind 0) (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 20 10 ind 0) (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0)))
(snd-display ";as-one-edit save-state 2: ~A" (channel->float-vector 0 10 ind 0))))
(lambda (ind)
(if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup float-vector+scl edpos: ~A" (edit-position ind 0)))
- (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector-scale! (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0) .5)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 0) (float-vector-scale! (float-vector .1 .2 .3 .4 .5 .6 .7 .8 .9 1.0) .5)))
(snd-display ";as-one-edit save-state 3: ~A" (channel->float-vector 0 10 ind 0))))
(lambda (ind)
(if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup float-vector+del edpos: ~A" (edit-position ind 0)))
- (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector .1 .2 .3 .4 .5 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 0) (float-vector .1 .2 .3 .4 .5 0 0 0 0 0)))
(snd-display ";as-one-edit save-state 4: ~A" (channel->float-vector 0 10 ind 0))))
(lambda (ind)
(if (not (= (edit-position ind 0) 1)) (snd-display ";save-state backup del+insert edpos: ~A" (edit-position ind 0)))
- (if (not (vequal (channel->float-vector 0 10 ind 0) (float-vector 0 0 0 0 0 .1 .2 0 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 0) (float-vector 0 0 0 0 0 .1 .2 0 0 0)))
(snd-display ";as-one-edit save-state 5: ~A" (channel->float-vector 0 10 ind 0)))
(if (not (= (framples ind 0) 97)) (snd-display ";save-state backup del+insert len: ~A" (framples ind 0))))
@@ -33060,7 +32784,7 @@ EDITS: 1
;; ---------------- edit-list->function ----------------
(let* ((ind (open-sound "oboe.snd"))
- (frs (framples)))
+ (frs (framples ind)))
;; ---- simple scale
(let ((mx0 (maxamp)))
@@ -33287,7 +33011,7 @@ EDITS: 1
(if (not (equal? (procedure-source func) '(lambda (snd chn) (insert-sample 100 0.1 snd chn))))
(snd-display ";edit-list->function 9: ~A" (procedure-source func)))
(func ind 0)
- (if (not (vequal (channel->float-vector 99 4) (float-vector 0.0 0.1 0.1 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 99 4) (float-vector 0.0 0.1 0.1 0.0)))
(snd-display ";edit-list->function func 9: ~A" (channel->float-vector 99 4)))
(if (not (= (framples) (+ frs 2))) (snd-display ";edit-list->function called (9): ~A ~A" frs (framples))))
(revert-sound ind)
@@ -33300,7 +33024,7 @@ EDITS: 1
(snd-display ";edit-list->function 9a: ~A" func))
(func ind 0))
(if (not (= (framples) (+ frs 200))) (snd-display ";edit-list->function insert-samples (200): ~A ~A" frs (framples)))
- (if (not (vequal (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
(snd-display ";edit-list->function func 9a: ~A" (channel->float-vector 0 5)))
(revert-sound ind)
@@ -33312,7 +33036,7 @@ EDITS: 1
(snd-display ";edit-list->function 9b: ~A" func))
(func ind 0))
(if (not (= (framples) frs)) (snd-display ";edit-list->function set-samples (2): ~A ~A" frs (framples)))
- (if (not (vequal (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 5) (float-vector 0.1 0.1 0.1 0.1 0.1)))
(snd-display ";edit-list->function func 9b: ~A" (channel->float-vector 0 5)))
(revert-sound ind)
@@ -33329,7 +33053,7 @@ EDITS: 1
(if (not (equal? (procedure-source func) '(lambda (snd chn) (set-sample 100 0.1 snd chn))))
(snd-display ";edit-list->function 10: ~A" (procedure-source func)))
(func ind 0)
- (if (not (vequal (channel->float-vector 99 4) (float-vector 0.0 0.1 0.0 0.0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 99 4) (float-vector 0.0 0.1 0.0 0.0)))
(snd-display ";edit-list->function func 10: ~A" (channel->float-vector 99 4)))))
(revert-sound ind)
@@ -33461,7 +33185,7 @@ EDITS: 1
(map-channel (lambda (y) 1.0))
(func ind 0)
(let ((data (channel->float-vector)))
- (if (not (vequal data (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 0.889 0.778 0.667 0.556 0.444 0.333 0.222 0.111 0.0)))
(snd-display ";edit-list->function env reapply: ~A" data)))
(close-sound ind)
(set! ind (open-sound "oboe.snd")))
@@ -33588,7 +33312,7 @@ EDITS: 1
val))))
(let ((vals (fft-env-data '(0 0 .3 0 .4 1 1 1))))
(float-vector->channel vals)
- (if (not (vequal vals (float-vector -0.000 0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500 -0.000
+ (if (not (mus-arrays-equal? vals (float-vector -0.000 0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500 -0.000
-0.500 -0.000 0.500 -0.000 -0.500 -0.000 0.500 0.000 -0.500 0.000 0.500
0.000 -0.500 0.000 0.500 -0.000 -0.500 -0.000 0.500 -0.000 -0.500)))
(snd-display ";fft-env-data: ~A" vals)))
@@ -33597,14 +33321,14 @@ EDITS: 1
(nvals (float-vector -0.500 -0.000 0.500 -0.000 -0.500 0.000 0.500 0.000 -0.500 0.000 0.500
0.000 -0.500 -0.000 0.500 -0.000 -0.500 -0.000 0.500 -0.000 -0.500 0.000
0.500 0.000 -0.500 0.000 0.500 0.000 -0.500 -0.000 0.500 -0.000)))
- (if (not (vequal vals nvals))
+ (if (not (mus-arrays-equal? vals nvals))
(snd-display ";hilbert via dft: ~A" vals)))
(revert-sound ind)
(map-channel (lambda (y) 1.0))
(powenv-channel '(0 0 .325 1 1 32.0 2 0 32.0))
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.107 0.206 0.298 0.384 0.463 0.536 0.605 0.668 0.727 0.781 0.832 0.879
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.107 0.206 0.298 0.384 0.463 0.536 0.605 0.668 0.727 0.781 0.832 0.879
0.922 0.963 1.000 1.000 0.787 0.618 0.484 0.377 0.293 0.226 0.173 0.130 0.097
0.070 0.049 0.032 0.019 0.008 0.000)))
(snd-display ";powenv-channel: ~A" vals)))
@@ -33619,14 +33343,14 @@ EDITS: 1
(begin
(replace-with-selection)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.000 0.032 0.065
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.000 0.032 0.065
0.097 0.129 0.161 0.194 0.226 0.581 0.613 0.645 0.677 0.710 0.742 0.774 0.806
0.839 0.871 0.903 0.935 0.968 1.000)))
(snd-display ";replace-with-selection: ~A" vals)))))
(set! (cursor ind 0) 2)
(replace-with-selection)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.032 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.000 0.032 0.065
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.032 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.000 0.032 0.065
0.097 0.129 0.161 0.194 0.226 0.581 0.613 0.645 0.677 0.710 0.742 0.774 0.806
0.839 0.871 0.903 0.935 0.968 1.000)))
(snd-display ";replace-with-selection (at 2): ~A" vals)))
@@ -33639,7 +33363,7 @@ EDITS: 1
(make-selection 0 9)
(fit-selection-between-marks m1 m2)
(let ((vals (channel->float-vector)))
- (if (not (vequal vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.323 0.387 0.452
+ (if (not (mus-arrays-equal? vals (float-vector 0.000 0.032 0.065 0.097 0.129 0.161 0.194 0.226 0.258 0.290 0.323 0.387 0.452
0.516 0.581 0.645 0.710 0.774 0.839 0.903 0.645 0.677 0.710 0.742 0.774 0.806
0.839 0.871 0.903 0.935 0.968 1.000)))
(snd-display ";fit-selection-between-marks: ~A" vals))))
@@ -33650,7 +33374,7 @@ EDITS: 1
(let ((ramper (make-ramp 10)))
(map-channel (lambda (y) (ramp ramper y)))
(let ((vals (channel->float-vector 0 20)))
- (if (not (vequal vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900 1.000 1.0
+ (if (not (mus-arrays-equal? vals (float-vector 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900 1.000 1.0
1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
(snd-display ";make-ramp: ~A" vals))))
(revert-sound ind)
@@ -33664,7 +33388,7 @@ EDITS: 1
(if (file-exists? new-file-name) (delete-file new-file-name))))
(let ((vals (apply float-vector (rms-envelope "oboe.snd" :rfreq 4))))
- (if (not (vequal vals (float-vector 0.0 0.0430 0.25 0.0642 0.5 0.0695 0.75 0.0722 1.0 0.0738 1.25 0.0713
+ (if (not (mus-arrays-equal? vals (float-vector 0.0 0.0430 0.25 0.0642 0.5 0.0695 0.75 0.0722 1.0 0.0738 1.25 0.0713
1.5 0.065 1.75 0.0439 2.0 0.01275 2.25 0.007)))
(snd-display ";rms-envelope: ~A" vals)))
@@ -33702,9 +33426,9 @@ EDITS: 1
(map-channel (lambda (y) 0.5))
(map-channel (vibro 1000.0 .5))
(let ((vals (channel->float-vector 0 20)))
- (if (not (or (vequal vals (float-vector 0.375 0.410 0.442 0.469 0.489 0.499 0.499 0.489 0.470 0.443 0.411 0.376
+ (if (not (or (mus-arrays-equal? vals (float-vector 0.375 0.410 0.442 0.469 0.489 0.499 0.499 0.489 0.470 0.443 0.411 0.376
0.341 0.308 0.281 0.262 0.251 0.251 0.261 0.280))
- (vequal vals (float-vector 0.375 0.393 0.410 0.427 0.442 0.457 0.469 0.480 0.489 0.495 0.499 0.500
+ (mus-arrays-equal? vals (float-vector 0.375 0.393 0.410 0.427 0.442 0.457 0.469 0.480 0.489 0.495 0.499 0.500
0.499 0.495 0.489 0.480 0.470 0.457 0.443 0.428))))
(snd-display ";no vibro? ~A" vals)))
(let ((new-file-name (file-name ind)))
@@ -33873,70 +33597,68 @@ EDITS: 1
(lambda () (effects-jc-reverb-1 0.1 0 #f))
)
- (list
- '(lambda (snd chn) (insert-float-vector (float-vector 1.0 0.5) 0 2 snd chn))
- '(lambda (snd chn) (clm-channel-test snd chn))
-
- '(lambda (snd chn) (fft-edit 1000 3000 snd chn))
- '(lambda (snd chn) (fft-squelch 0.01 snd chn))
- '(lambda (snd chn) (fft-cancel 1000 3000 snd chn))
- '(lambda (snd chn) (squelch-vowels snd chn))
- '(lambda (snd chn) (fft-env-edit '(0 0 1 1 2 0) snd chn))
- '(lambda (snd chn) (fft-env-interp '(0 0 1 1 2 0) '(0 1 1 0 2 0) '(0 0 1 1) snd chn))
- '(lambda (snd chn) (hello-dentist 10.0 0.1 snd chn))
- '(lambda (snd chn) (fp 1.0 0.3 20.0 snd chn))
- '(lambda (snd chn) (expsnd '(0 1 1 2) snd chn))
- '(lambda (snd chn) (env-sound-interp '(0 0 1 1 2 0) 2.0 snd chn))
- '(lambda (snd chn) (add-notes '(("1a.snd") ("pistol.snd" 1.0 2.0)) snd chn))
- '(lambda (snd chn) (filtered-env '(0 0 1 1 2 0) snd chn))
- '(lambda (snd chn) (reverse-by-blocks 0.1 snd chn))
- '(lambda (snd chn) (reverse-within-blocks 0.1 snd chn))
-
- '(lambda (snd chn) (mix-channel "1a.snd" 1200 #f snd chn))
- '(lambda (snd chn) (insert-channel "1a.snd" 1200 #f snd chn))
- '(lambda (snd chn) (sine-ramp 0.5 0.9 0 #f snd chn))
- '(lambda (snd chn) (sine-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
- '(lambda (snd chn) (blackman4-ramp 0.0 1.0 0 #f snd chn))
- '(lambda (snd chn) (blackman4-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
- '(lambda (snd chn) (ramp-squared 0.2 0.8 #t 0 #f snd chn))
- '(lambda (snd chn) (env-squared-channel '(0.0 0.0 1.0 1.0) #t 0 #f snd chn))
- '(lambda (snd chn) (ramp-expt 0.2 0.8 32.0 #t 0 #f snd chn))
- '(lambda (snd chn) (env-expt-channel '(0.0 0.0 1.0 1.0) 32.0 #t 0 #f snd chn))
- '(lambda (snd chn) (offset-channel 0.1 0 #f snd chn))
- '(lambda (snd chn) (dither-channel 0.1 0 #f snd chn))
- '(lambda (snd chn) (contrast-channel 0.1 0 #f snd chn))
-
- '(lambda (snd chn) (ssb-bank 550 600 10 40 50.0 0 #f snd chn))
- '(lambda (snd chn) (ssb-bank-env 550 600 '(0 1 1 2) 10 40 50.0 0 #f snd chn))
- '(lambda (snd chn) (down-oct 1 snd chn))
- '(lambda (snd chn) (spike snd chn))
- '(lambda (snd chn) (zero-phase snd chn))
- '(lambda (snd chn) (rotate-phase (lambda (x) (random pi)) snd chn))
- '(lambda (snd chn) (brighten-slightly 0.5 snd chn))
- '(lambda (snd chn) (shift-channel-pitch 100 40 0 #f snd chn))
- '(lambda (snd chn) (channel-polynomial (float-vector 0.0 0.5) snd chn))
- '(lambda (snd chn) (spectral-polynomial (float-vector 0.0 1.0) snd chn))
- '(lambda (snd chn) (notch-channel '(60.0 120.0 240.0) #f #f #f snd chn))
-
- '(lambda (snd chn) (effects-squelch-channel 0.1 128 snd chn))
- '(lambda (snd chn) (effects-echo #f 0.5 0.1 0 #f snd chn))
- '(lambda (snd chn) (effects-flecho-1 0.5 0.1 #f 0 #f snd chn))
- '(lambda (snd chn) (effects-zecho-1 0.75 0.75 6.0 10.0 #f 0 #f snd chn))
- ;; '(lambda (snd chn) (effects-comb-filter 0.1 50 0 #f snd chn))
- '(lambda (snd chn) (effects-moog 10000 0.5 0 #f snd chn))
- '(lambda (snd chn) (effects-remove-dc snd chn))
- '(lambda (snd chn) (effects-compand snd chn))
- '(lambda (snd chn) (effects-am 100.0 #f #f #f snd chn))
- '(lambda (snd chn) (effects-rm 100.0 #f #f #f snd chn))
- '(lambda (snd chn) (effects-bbp 1000.0 100.0 0 #f snd chn))
- '(lambda (snd chn) (effects-bbr 1000.0 100.0 0 #f snd chn))
- '(lambda (snd chn) (effects-bhp 1000.0 0 #f snd chn))
- '(lambda (snd chn) (effects-blp 1000.0 0 #f snd chn))
- '(lambda (snd chn) (effects-hello-dentist 50.0 0.5 0 #f snd chn))
- '(lambda (snd chn) (effects-fp 1.0 0.3 20.0 0 #f snd chn))
- '(lambda (snd chn) (effects-flange 5.0 2.0 0.001 0 #f snd chn))
- '(lambda (snd chn) (effects-jc-reverb-1 0.1 0 #f snd chn))
- ))))
+ '((lambda (snd chn) (insert-float-vector (float-vector 1.0 0.5) 0 2 snd chn))
+ (lambda (snd chn) (clm-channel-test snd chn))
+
+ (lambda (snd chn) (fft-edit 1000 3000 snd chn))
+ (lambda (snd chn) (fft-squelch 0.01 snd chn))
+ (lambda (snd chn) (fft-cancel 1000 3000 snd chn))
+ (lambda (snd chn) (squelch-vowels snd chn))
+ (lambda (snd chn) (fft-env-edit '(0 0 1 1 2 0) snd chn))
+ (lambda (snd chn) (fft-env-interp '(0 0 1 1 2 0) '(0 1 1 0 2 0) '(0 0 1 1) snd chn))
+ (lambda (snd chn) (hello-dentist 10.0 0.1 snd chn))
+ (lambda (snd chn) (fp 1.0 0.3 20.0 snd chn))
+ (lambda (snd chn) (expsnd '(0 1 1 2) snd chn))
+ (lambda (snd chn) (env-sound-interp '(0 0 1 1 2 0) 2.0 snd chn))
+ (lambda (snd chn) (add-notes '(("1a.snd") ("pistol.snd" 1.0 2.0)) snd chn))
+ (lambda (snd chn) (filtered-env '(0 0 1 1 2 0) snd chn))
+ (lambda (snd chn) (reverse-by-blocks 0.1 snd chn))
+ (lambda (snd chn) (reverse-within-blocks 0.1 snd chn))
+
+ (lambda (snd chn) (mix-channel "1a.snd" 1200 #f snd chn))
+ (lambda (snd chn) (insert-channel "1a.snd" 1200 #f snd chn))
+ (lambda (snd chn) (sine-ramp 0.5 0.9 0 #f snd chn))
+ (lambda (snd chn) (sine-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
+ (lambda (snd chn) (blackman4-ramp 0.0 1.0 0 #f snd chn))
+ (lambda (snd chn) (blackman4-env-channel '(0 0 1 1 2 -0.5 3 1) 0 #f snd chn))
+ (lambda (snd chn) (ramp-squared 0.2 0.8 #t 0 #f snd chn))
+ (lambda (snd chn) (env-squared-channel '(0.0 0.0 1.0 1.0) #t 0 #f snd chn))
+ (lambda (snd chn) (ramp-expt 0.2 0.8 32.0 #t 0 #f snd chn))
+ (lambda (snd chn) (env-expt-channel '(0.0 0.0 1.0 1.0) 32.0 #t 0 #f snd chn))
+ (lambda (snd chn) (offset-channel 0.1 0 #f snd chn))
+ (lambda (snd chn) (dither-channel 0.1 0 #f snd chn))
+ (lambda (snd chn) (contrast-channel 0.1 0 #f snd chn))
+
+ (lambda (snd chn) (ssb-bank 550 600 10 40 50.0 0 #f snd chn))
+ (lambda (snd chn) (ssb-bank-env 550 600 '(0 1 1 2) 10 40 50.0 0 #f snd chn))
+ (lambda (snd chn) (down-oct 1 snd chn))
+ (lambda (snd chn) (spike snd chn))
+ (lambda (snd chn) (zero-phase snd chn))
+ (lambda (snd chn) (rotate-phase (lambda (x) (random pi)) snd chn))
+ (lambda (snd chn) (brighten-slightly 0.5 snd chn))
+ (lambda (snd chn) (shift-channel-pitch 100 40 0 #f snd chn))
+ (lambda (snd chn) (channel-polynomial (float-vector 0.0 0.5) snd chn))
+ (lambda (snd chn) (spectral-polynomial (float-vector 0.0 1.0) snd chn))
+ (lambda (snd chn) (notch-channel '(60.0 120.0 240.0) #f #f #f snd chn))
+
+ (lambda (snd chn) (effects-squelch-channel 0.1 128 snd chn))
+ (lambda (snd chn) (effects-echo #f 0.5 0.1 0 #f snd chn))
+ (lambda (snd chn) (effects-flecho-1 0.5 0.1 #f 0 #f snd chn))
+ (lambda (snd chn) (effects-zecho-1 0.75 0.75 6.0 10.0 #f 0 #f snd chn))
+ ;; (lambda (snd chn) (effects-comb-filter 0.1 50 0 #f snd chn))
+ (lambda (snd chn) (effects-moog 10000 0.5 0 #f snd chn))
+ (lambda (snd chn) (effects-remove-dc snd chn))
+ (lambda (snd chn) (effects-compand snd chn))
+ (lambda (snd chn) (effects-am 100.0 #f #f #f snd chn))
+ (lambda (snd chn) (effects-rm 100.0 #f #f #f snd chn))
+ (lambda (snd chn) (effects-bbp 1000.0 100.0 0 #f snd chn))
+ (lambda (snd chn) (effects-bbr 1000.0 100.0 0 #f snd chn))
+ (lambda (snd chn) (effects-bhp 1000.0 0 #f snd chn))
+ (lambda (snd chn) (effects-blp 1000.0 0 #f snd chn))
+ (lambda (snd chn) (effects-hello-dentist 50.0 0.5 0 #f snd chn))
+ (lambda (snd chn) (effects-fp 1.0 0.3 20.0 0 #f snd chn))
+ (lambda (snd chn) (effects-flange 5.0 2.0 0.001 0 #f snd chn))
+ (lambda (snd chn) (effects-jc-reverb-1 0.1 0 #f snd chn))))))
(close-sound ind)
)
@@ -33945,7 +33667,7 @@ EDITS: 1
(let ((ind (open-sound "oboe.snd")))
(let ((original-maxamp (maxamp)))
(reset-controls)
- (controls->channel (list 2.0))
+ (controls->channel '(2.0))
(if (fneq (amp-control ind) 1.0) (snd-display ";controls->channel amp: ~A" (amp-control ind)))
(if (fneq (maxamp) (* 2 original-maxamp)) (snd-display ";controls->channel maxamp: ~A" (maxamp))))
(let ((func (edit-list->function)))
@@ -33954,7 +33676,7 @@ EDITS: 1
(func ind 0)
(revert-sound ind))
- (controls->channel (list #f 2.0))
+ (controls->channel '(#f 2.0))
(let ((pk (float-vector-peak (channel->float-vector 22000 22100))))
(if (fneq pk 0.0479) (snd-display ";dp->end screwed up again!?!: ~A" pk)))
(let ((func (edit-list->function)))
@@ -34046,12 +33768,10 @@ EDITS: 1
(let ((ind (open-sound "oboe.snd")))
(let ((tag (catch #t (lambda () (save-sound-as "test.snd" :edit-position 1)) (lambda args args))))
- (if (not (and tag
- (eq? (car tag) 'no-such-edit)))
+ (if (not (and (pair? tag) (eq? (car tag) 'no-such-edit)))
(snd-display ";save-sound-as bad edpos: ~A" tag)))
(let ((tag (catch #t (lambda () (save-sound-as "test.snd" :channel 1 :edit-position 1)) (lambda args args))))
- (if (not (and tag
- (eq? (car tag) 'no-such-channel)))
+ (if (not (and (pair? tag) (eq? (car tag) 'no-such-channel)))
(snd-display ";save-sound-as bad chan: ~A" tag)))
(save-sound-as "test.snd" :comment "this is a comment")
(close-sound ind)
@@ -34092,7 +33812,7 @@ EDITS: 1
(lambda (x)
(if (fneq (bes-j0 x) (bes-j0-1 x))
(snd-display ";(bes-j0 ~A) -> ~A ~A" x (bes-j0 x) (bes-j0-1 x))))
- (list 0.0 0.5 1.0 2.0 20.0))
+ '(0.0 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
@@ -34127,7 +33847,7 @@ EDITS: 1
(lambda (x)
(if (fneq (bes-j1 x) (bes-j1-1 x))
(snd-display ";(bes-j1 ~A) -> ~A ~A" x (bes-j1 x) (bes-j1-1 x))))
- (list 0.0 0.5 1.0 2.0 20.0))
+ '(0.0 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
@@ -34219,7 +33939,7 @@ EDITS: 1
(lambda (x)
(if (fneq (bes-y0 x) (bes-y0-1 x))
(snd-display ";(bes-y0 ~A) -> ~A ~A" x (bes-y0 x) (bes-y0-1 x))))
- (list 0.5 1.0 2.0 20.0))
+ '(0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
@@ -34251,7 +33971,7 @@ EDITS: 1
(lambda (x)
(if (fneq (bes-y1 x) (bes-y1-1 x))
(snd-display ";(bes-y1 ~A) -> ~A ~A" x (bes-y1 x) (bes-y1-1 x))))
- (list 0.01 0.5 1.0 2.0 20.0))
+ '(0.01 0.5 1.0 2.0 20.0))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 100.0)))
@@ -34304,7 +34024,7 @@ EDITS: 1
(lambda (x)
(if (fneq (bes-i0 x) (bes-i0-1 x))
(snd-display ";(bes-i0 ~A) -> ~A ~A" x (bes-i0 x) (bes-i0-1 x))))
- (list 0.0 0.5 1.0 2.0 0.01))
+ '(0.0 0.5 1.0 2.0 0.01))
(do ((i 0 (+ i 1)))
((= i 10))
(let ((x (random 1.0)))
@@ -34326,7 +34046,7 @@ EDITS: 1
(ans1 (+ 0.02282967 (* y (- (* y (+ 0.01787654 (* y -0.00420059))) 0.02895312))))
(ans2 (+ 0.39894228 (* y (- (* y (- (* y (+ 0.00163801 (* y (- (* y ans1) 0.01031555)))) 0.00362018)) 0.03988024))))
(sign (if (< x 0.0) -1.0 1.0)))
- (* (/ (exp ax) (sqrt ax)) ans2 sign))))
+ (/ (* (exp ax) ans2 sign) (sqrt ax)))))
(define (test-i1)
(if (fneq (bes-i1 1.0) 0.565159) (snd-display ";bes-i1 1.0: ~A" (bes-i1 1.0)))
@@ -34364,23 +34084,24 @@ EDITS: 1
(set! ans (- ans)))
(* ans (/ (bes-i0 x) bi))))))
- (if (fneq (bes-in 1 1.0) 0.565159) (snd-display ";bes-in 1 1.0: ~A" (bes-in 1 1.0)))
- (if (fneq (bes-in 2 1.0) 0.13574767) (snd-display ";bes-in 2 1.0: ~A" (bes-in 2 1.0)))
- (if (fneq (bes-in 3 1.0) 0.02216842) (snd-display ";bes-in 3 1.0: ~A" (bes-in 3 1.0)))
- (if (fneq (bes-in 5 1.0) 2.71463e-4) (snd-display ";bes-in 5 1.0: ~A" (bes-in 5 1.0)))
- (if (fneq (bes-in 10 1.0) 2.752948e-10) (snd-display ";bes-in 10 1.0: ~A" (bes-in 10 1.0)))
-
- (if (fneq (bes-in 1 2.0) 1.5906368) (snd-display ";bes-in 1 2.0: ~A" (bes-in 1 2.0)))
- (if (fneq (bes-in 2 2.0) 0.6889484) (snd-display ";bes-in 2 2.0: ~A" (bes-in 2 2.0)))
- (if (fneq (bes-in 3 2.0) 0.21273995) (snd-display ";bes-in 3 2.0: ~A" (bes-in 3 2.0)))
- (if (fneq (bes-in 5 2.0) 0.009825679) (snd-display ";bes-in 5 2.0: ~A" (bes-in 5 2.0)))
- (if (fneq (bes-in 10 2.0) 3.016963e-7) (snd-display ";bes-in 10 2.0: ~A" (bes-in 10 2.0)))
-
- (if (fneq (bes-in 1 5.0) 24.33564) (snd-display ";bes-in 1 5.0: ~A" (bes-in 1 5.0)))
- (if (fneq (bes-in 2 5.0) 17.505615) (snd-display ";bes-in 2 5.0: ~A" (bes-in 2 5.0)))
- (if (fneq (bes-in 3 5.0) 10.331150) (snd-display ";bes-in 3 5.0: ~A" (bes-in 3 5.0)))
- (if (fneq (bes-in 5 5.0) 2.157974) (snd-display ";bes-in 5 5.0: ~A" (bes-in 5 5.0)))
- (if (fneq (bes-in 10 5.0) 0.004580044) (snd-display ";bes-in 10 5.0: ~A" (bes-in 10 5.0))))
+ (when (not (provided? 'solaris))
+ (if (fneq (bes-in 1 1.0) 0.565159) (snd-display ";bes-in 1 1.0: ~A" (bes-in 1 1.0)))
+ (if (fneq (bes-in 2 1.0) 0.13574767) (snd-display ";bes-in 2 1.0: ~A" (bes-in 2 1.0)))
+ (if (fneq (bes-in 3 1.0) 0.02216842) (snd-display ";bes-in 3 1.0: ~A" (bes-in 3 1.0)))
+ (if (fneq (bes-in 5 1.0) 2.71463e-4) (snd-display ";bes-in 5 1.0: ~A" (bes-in 5 1.0)))
+ (if (fneq (bes-in 10 1.0) 2.752948e-10) (snd-display ";bes-in 10 1.0: ~A" (bes-in 10 1.0)))
+
+ (if (fneq (bes-in 1 2.0) 1.5906368) (snd-display ";bes-in 1 2.0: ~A" (bes-in 1 2.0)))
+ (if (fneq (bes-in 2 2.0) 0.6889484) (snd-display ";bes-in 2 2.0: ~A" (bes-in 2 2.0)))
+ (if (fneq (bes-in 3 2.0) 0.21273995) (snd-display ";bes-in 3 2.0: ~A" (bes-in 3 2.0)))
+ (if (fneq (bes-in 5 2.0) 0.009825679) (snd-display ";bes-in 5 2.0: ~A" (bes-in 5 2.0)))
+ (if (fneq (bes-in 10 2.0) 3.016963e-7) (snd-display ";bes-in 10 2.0: ~A" (bes-in 10 2.0)))
+
+ (if (fneq (bes-in 1 5.0) 24.33564) (snd-display ";bes-in 1 5.0: ~A" (bes-in 1 5.0)))
+ (if (fneq (bes-in 2 5.0) 17.505615) (snd-display ";bes-in 2 5.0: ~A" (bes-in 2 5.0)))
+ (if (fneq (bes-in 3 5.0) 10.331150) (snd-display ";bes-in 3 5.0: ~A" (bes-in 3 5.0)))
+ (if (fneq (bes-in 5 5.0) 2.157974) (snd-display ";bes-in 5 5.0: ~A" (bes-in 5 5.0)))
+ (if (fneq (bes-in 10 5.0) 0.004580044) (snd-display ";bes-in 10 5.0: ~A" (bes-in 10 5.0)))))
(define (bes-k0 x) ;K0(x)
(if (<= x 2.0)
@@ -34455,9 +34176,8 @@ EDITS: 1
(define (test-lgamma)
- (define (gammln xx) ;Ln(gamma(xx)), xx>0
+ (define (gammln x) ;Ln(gamma(x)), x>0
(let* ((stp 2.5066282746310005e0)
- (x xx)
(tmp (+ x 5.5))
(tmp1 (- tmp (* (+ x 0.5) (log tmp))))
(ser (+ 1.000000000190015
@@ -34602,11 +34322,7 @@ EDITS: 1
(set! (data0 (- dlen 1)) orig))))))
(define (cross-correlate-2 snd0 chn0 snd1 chn1)
- (let* ((len0 (framples snd0 chn0))
- (len1 (framples snd1 chn1))
- (ilen (max len0 len1))
- (pow2 (ceiling (log ilen 2)))
- (fftlen (expt 2 pow2))
+ (let* ((fftlen (expt 2 (ceiling (log (max (framples snd0 chn0) (framples snd1 chn1)) 2))))
(fftscale (/ 1.0 fftlen))
(rl1 (channel->float-vector 0 fftlen snd1 chn1))
(rl2 (channel->float-vector 0 fftlen snd0 chn0))
@@ -34642,8 +34358,7 @@ EDITS: 1
(define* (automorph a b c d snd chn)
(let* ((len (framples snd chn))
- (pow2 (ceiling (log len 2)))
- (fftlen (expt 2 pow2))
+ (fftlen (expt 2 (ceiling (log len 2))))
(fftlen2 (/ fftlen 2))
(fftscale (/ 1.0 fftlen))
(rl (channel->float-vector 0 fftlen snd chn))
@@ -34768,7 +34483,7 @@ EDITS: 1
(set! *transform-size* size)
(update-transform-graph))
(lambda args args)))
- (list 8 7 -7 4 3 2 1 0)))
+ '(8 7 -7 4 3 2 1 0)))
(list fourier-transform wavelet-transform autocorrelation walsh-transform cepstrum haar-transform))
(close-sound index))
@@ -34824,31 +34539,31 @@ EDITS: 1
(float-vector-scale! i1 .3333)
(float-vector-add! r0 r1)
(float-vector-add! i0 i1)
- (if (not (and (vequal r0 r2)
- (vequal i0 i2)))
+ (if (not (and (mus-arrays-equal? r0 r2)
+ (mus-arrays-equal? i0 i2)))
(snd-display ";fft additions/scaling: ~A ~A: ~A ~A" r2 i2 r0 i0)))
(set! d0 (make-float-vector 8))
(set! d1 (make-float-vector 8))
(set! (d0 2) 1.0)
(mus-fft d0 d1 8 1)
- (if (not (and (vequal d0 (float-vector 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000 0.000))
- (vequal d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
+ (if (not (and (mus-arrays-equal? d0 (float-vector 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000 0.000))
+ (mus-arrays-equal? d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
(snd-display ";mus-fft 1: ~A ~A?" d0 d1))
(mus-fft d0 d1 8 -1)
- (if (not (and (vequal d0 (float-vector 0.000 0.000 8.000 0.000 0.000 0.000 0.000 0.000))
- (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? d0 (float-vector 0.000 0.000 8.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal? d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";mus-fft -1: ~A ~A?" d0 d1))
(fill! d0 1.0)
(fill! d1 0.0)
(mus-fft d0 d1 8)
- (if (not (and (vequal d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
- (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))
+ (mus-arrays-equal? d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";mus-fft 2: ~A ~A?" d0 d1))
(mus-fft d0 d1 8 -1)
- (if (not (and (vequal d0 (float-vector 8.000 8.000 8.000 8.000 8.000 8.000 8.000 8.000))
- (vequal d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
+ (if (not (and (mus-arrays-equal? d0 (float-vector 8.000 8.000 8.000 8.000 8.000 8.000 8.000 8.000))
+ (mus-arrays-equal? d1 (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000))))
(snd-display ";mus-fft -2: ~A ~A?" d0 d1))
(fill! d1 0.0)
@@ -34857,7 +34572,7 @@ EDITS: 1
(mus-fft d0 d1 8)
(mus-fft d0 d1 8 -1)
(float-vector-scale! d0 (/ 1.0 8.0))
- (if (not (vequal d0 fn))
+ (if (not (mus-arrays-equal? d0 fn))
(snd-display ";mus-fft 3: ~A ~A?" d0 fn))
(let ((d0 (make-float-vector 8))
@@ -34888,9 +34603,9 @@ EDITS: 1
(mus-fft d0 d1 8)
(float-vector-scale! d0 .125)
(float-vector-scale! d1 .125)
- (if (not (vequal d0 save-d0))
+ (if (not (mus-arrays-equal? d0 save-d0))
(snd-display ";mus-fft d0 saved: ~A ~A" d0 save-d0))
- (if (not (vequal d1 save-d1))
+ (if (not (mus-arrays-equal? d1 save-d1))
(snd-display ";mus-fft d1 saved: ~A ~A" d1 save-d1))))
(for-each
@@ -34900,7 +34615,7 @@ EDITS: 1
(set! (d0 0) 1.0)
(set! dcopy (copy d0))
(set! d1 (snd-spectrum d0 rectangular-window size))
- (if (not (vequal d0 dcopy)) (snd-display ";snd-spectrum not in-place? ~A ~A" d0 dcopy)))
+ (if (not (mus-arrays-equal? d0 dcopy)) (snd-display ";snd-spectrum not in-place? ~A ~A" d0 dcopy)))
(let ((happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i (/ size 2))))
@@ -34949,8 +34664,8 @@ EDITS: 1
(set! (d0 0) 1.0)
(set! dcopy (copy d0))
(set! d1 (snd-spectrum d0 rectangular-window size #t 1.0 #t)) ; in-place
- (if (vequal d0 dcopy) (snd-display ";snd-spectrum in-place? ~A ~A" d0 dcopy))
- (if (not (vequal d0 d1)) (snd-display ";snd-spectrum returns in-place? ~A ~A" d0 d1)))
+ (if (mus-arrays-equal? d0 dcopy) (snd-display ";snd-spectrum in-place? ~A ~A" d0 dcopy))
+ (if (not (mus-arrays-equal? d0 d1)) (snd-display ";snd-spectrum returns in-place? ~A ~A" d0 d1)))
(let ((happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i (/ size 2))))
@@ -34964,8 +34679,8 @@ EDITS: 1
(set! (d0 0) 1.0)
(set! dcopy (copy d0))
(set! d1 (snd-spectrum d0 rectangular-window size #f 1.0 #t)) ; in-place dB
- (if (vequal d0 dcopy) (snd-display ";snd-spectrum dB in-place? ~A ~A" d0 dcopy))
- (if (not (vequal d0 d1)) (snd-display ";snd-spectrum dB returns in-place? ~A ~A" d0 d1)))
+ (if (mus-arrays-equal? d0 dcopy) (snd-display ";snd-spectrum dB in-place? ~A ~A" d0 dcopy))
+ (if (not (mus-arrays-equal? d0 d1)) (snd-display ";snd-spectrum dB returns in-place? ~A ~A" d0 d1)))
(let ((happy #t))
(do ((i 0 (+ i 1)))
((or (not happy) (= i (/ size 2))))
@@ -34987,25 +34702,25 @@ EDITS: 1
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 blackman2-window size))
- (if (not (or (vequal d1 (float-vector 1.000 0.721 0.293 0.091))
- (vequal d1 (float-vector 1.000 0.647 0.173 0.037 0.024 0.016 0.011 0.005))))
+ (if (not (or (mus-arrays-equal? d1 (float-vector 1.000 0.721 0.293 0.091))
+ (mus-arrays-equal? d1 (float-vector 1.000 0.647 0.173 0.037 0.024 0.016 0.011 0.005))))
(snd-display ";blackman2 snd-spectrum: ~A~%" d1))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 gaussian-window size #t 0.5))
- (if (not (or (vequal d1 (float-vector 1.000 0.900 0.646 0.328))
- (vequal d1 (float-vector 1.000 0.870 0.585 0.329 0.177 0.101 0.059 0.028))))
+ (if (not (or (mus-arrays-equal? d1 (float-vector 1.000 0.900 0.646 0.328))
+ (mus-arrays-equal? d1 (float-vector 1.000 0.870 0.585 0.329 0.177 0.101 0.059 0.028))))
(snd-display ";gaussian 0.5 snd-spectrum: ~A~%" d1))
(set! d0 (make-float-vector size 1.0))
(set! d1 (snd-spectrum d0 gaussian-window size #t 0.85))
- (if (not (or (vequal d1 (float-vector 1.000 0.924 0.707 0.383))
- (vequal d1 (float-vector 1.000 0.964 0.865 0.725 0.566 0.409 0.263 0.128))))
+ (if (not (or (mus-arrays-equal? d1 (float-vector 1.000 0.924 0.707 0.383))
+ (mus-arrays-equal? d1 (float-vector 1.000 0.964 0.865 0.725 0.566 0.409 0.263 0.128))))
(snd-display ";gaussian 0.85 snd-spectrum: ~A~%" d1))
)
- (list 8 16))
+ '(8 16))
(for-each
(lambda (len)
@@ -35026,7 +34741,7 @@ EDITS: 1
(if (fneq (rl 0) (* len len)) (snd-display ";snd-transform ~A at 0: ~A" len (rl 0)))
(set! (rl 0) 0.0)
(if (> (float-vector-peak rl) .001) (snd-display ";snd-transform ~A impulse: ~A" len (float-vector-peak rl)))))
- (list 16 128 512 1024))
+ '(16 128 512 1024))
(for-each
(lambda (len)
@@ -35045,7 +34760,7 @@ EDITS: 1
(snd-display ";impulse fft: ~A at ~A: ~A ~A" len i (rl i) (xrl i))
(set! happy #f)))))
(if (fneq (rl 0) 1.0) (snd-display ";flat ~A at 0: ~A" len (rl 0)))))
- (list 16 128 512 1024))
+ '(16 128 512 1024))
(for-each
(lambda (len)
@@ -35059,9 +34774,9 @@ EDITS: 1
(float-vector-scale! rl (/ 1.0 len))
(snd-transform fourier-transform xrl #t)
(float-vector-scale! xrl (/ 1.0 len))
- (if (not (vequal rl xrl))
+ (if (not (mus-arrays-equal? rl xrl))
(snd-display ";random fft: ~A: ~A ~A" len rl xrl))))
- (list 16 128 512 1024 4096))
+ '(16 128 512 1024 4096))
(for-each
(lambda (len)
@@ -35076,30 +34791,30 @@ EDITS: 1
(float-vector-scale! rl (/ 1.0 len))
(snd-transform fourier-transform xrl #t)
(float-vector-scale! xrl (/ 1.0 len))
- (if (not (vequal rl xrl))
+ (if (not (mus-arrays-equal? rl xrl))
(snd-display ";random fft: ~A: ~A ~A" len rl xrl))))
- (list 16 128 512 1024 4096))
+ '(16 128 512 1024 4096))
;; -------- autocorrelation
- (let ((rl (make-float-vector 16 0.0)))
+ (let ((rl (make-float-vector 16)))
(set! (rl 0) 1.0)
(autocorrelate rl)
- (if (not (vequal rl (float-vector 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? rl (float-vector 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";autocorrelate 1: ~A" rl)))
- (let ((rl (make-float-vector 16 0.0)))
+ (let ((rl (make-float-vector 16)))
(set! (rl 0) 1.0)
(set! (rl 1) -1.0)
(autocorrelate rl)
- (if (not (vequal rl (float-vector 2 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? rl (float-vector 2 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";autocorrelate 1 -1: ~A" rl)))
- (let ((rl (make-float-vector 16 0.0)))
+ (let ((rl (make-float-vector 16)))
(set! (rl 0) 1.0)
(set! (rl 4) -1.0)
(autocorrelate rl)
- (if (not (vequal rl (float-vector 2 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? rl (float-vector 2 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0)))
(snd-display ";autocorrelate 1 0 0 0 -1: ~A" rl)))
(let ((rl (make-float-vector 16))
@@ -35110,7 +34825,7 @@ EDITS: 1
(copy rl rl1)
(let ((nr (float-vector-subseq (corr rl rl 16 16) 0 15)))
(autocorrelate rl1)
- (if (not (vequal rl1 nr))
+ (if (not (mus-arrays-equal? rl1 nr))
(snd-display ";autocorrelate/corr (ramp):~%; ~A~%; ~A" rl1 nr))))
(let ((rl (make-float-vector 16))
@@ -35121,7 +34836,7 @@ EDITS: 1
(copy rl rl1)
(let ((nr (float-vector-subseq (corr rl rl 16 16) 0 15)))
(autocorrelate rl1)
- (if (not (vequal rl1 nr))
+ (if (not (mus-arrays-equal? rl1 nr))
(snd-display ";autocorrelate/corr:~%; ~A~%; ~A" rl1 nr))))
(let ((ind0 (new-sound "test.snd" :size 16))
@@ -35130,13 +34845,13 @@ EDITS: 1
(set! (sample 6 ind1 0) -.5)
(let ((data0 (cross-correlate-1 ind0 0 ind1 0))
(data1 (cross-correlate-2 ind0 0 ind1 0)))
- (if (not (vequal data0 data1))
+ (if (not (mus-arrays-equal? data0 data1))
(snd-display ";cross-correlate: ~A ~A" data0 data1)))
(set! (sample 3 ind0 0) 0.0)
(set! (sample 8 ind0 0) 1.0)
(let ((data0 (cross-correlate-1 ind0 0 ind1 0))
(data1 (cross-correlate-2 ind0 0 ind1 0)))
- (if (not (vequal data0 data1))
+ (if (not (mus-arrays-equal? data0 data1))
(snd-display ";cross-correlate 1: ~A ~A" data0 data1)))
(close-sound ind0)
(close-sound ind1))
@@ -35151,7 +34866,7 @@ EDITS: 1
(set! (v4 3) 1.0)
(set! v1 (cross-correlate-3 v1 v2 16))
(set! v3 (correlate v3 v4))
- (if (not (vequal v1 v3))
+ (if (not (mus-arrays-equal? v1 v3))
(snd-display ";correlate 16:~%; ~A~%; ~A" v1 v3)))
(let ((v1 (make-float-vector 128))
@@ -35164,7 +34879,7 @@ EDITS: 1
(set! (v4 32) 1.0)
(set! v1 (cross-correlate-3 v1 v2 128))
(set! v3 (correlate v3 v4))
- (if (not (vequal v1 v3))
+ (if (not (mus-arrays-equal? v1 v3))
(snd-display ";correlate 128:~%; ~A~%; ~A" v1 v3)))
(let ((v1 (make-float-vector 128))
@@ -35179,7 +34894,7 @@ EDITS: 1
(set! v4 (copy v2))
(set! v1 (cross-correlate-3 v1 v2 128))
(set! v3 (correlate v3 v4))
- (if (not (vequal v1 v3))
+ (if (not (mus-arrays-equal? v1 v3))
(snd-display ";correlate 128 at random:~%; ~A~%; ~A" v1 v3)))
(let ((v1 (make-float-vector 16))
@@ -35188,7 +34903,7 @@ EDITS: 1
(set! (v2 3) 1.0)
(set! v1 (correlate v1 (copy v1)))
(set! v2 (autocorrelate v2))
- (if (not (vequal v1 v2))
+ (if (not (mus-arrays-equal? v1 v2))
(snd-display ";auto/correlate 16:~%; ~A~%; ~A" v1 v2)))
(for-each
@@ -35231,7 +34946,7 @@ EDITS: 1
(set! (rl 4) 0.0)
(fill! rl 0.0 len2 len)
(if (> (float-vector-peak rl) .001) (snd-display ";autocorrelate peak: ~A" (float-vector-peak rl)))))
- (list 16 64 256 512))
+ '(16 64 256 512))
(for-each
(lambda (len)
@@ -35265,7 +34980,7 @@ EDITS: 1
(begin
(snd-display ";random ~A at ~A: ~A ~A" len i (rl i) (xrl i))
(set! happy #f)))))))
- (list 16 64 256 512))
+ '(16 64 256 512))
;; -------- cepstrum
@@ -35275,7 +34990,7 @@ EDITS: 1
-0.438549 -1.520463 -0.312065 -0.724707 1.154010 1.466936 0.110463 -1.520854)))
(do ((i 0 (+ i 1))) ((= i 16)) (set! (rl i) (lst i)))
(let ((nrl (float-vector-scale! (snd-transform cepstrum rl 0) 1.399)))
- (if (not (vequal nrl (float-vector 1.3994950 0.1416877 0.0952407 0.0052814 -0.0613192 0.0082986 -0.0233993
+ (if (not (mus-arrays-equal? nrl (float-vector 1.3994950 0.1416877 0.0952407 0.0052814 -0.0613192 0.0082986 -0.0233993
-0.0476585 0.0259498 -0.0476585 -0.0233993 0.0082986 -0.0613192 0.0052814
0.0952407 0.1416877)))
(snd-display ";cepstrum 16: ~A" nrl))))
@@ -35283,7 +34998,7 @@ EDITS: 1
(let ((rl (make-float-vector 16)))
(do ((i 0 (+ i 1))) ((= i 16)) (set! (rl i) i))
(let ((nrl (float-vector-scale! (snd-transform cepstrum rl 0) 2.72)))
- (if (not (vequal nrl (float-vector 2.720 0.452 0.203 0.122 0.082 0.061 0.048 0.041 0.039 0.041 0.048 0.061 0.082 0.122 0.203 0.452)))
+ (if (not (mus-arrays-equal? nrl (float-vector 2.720 0.452 0.203 0.122 0.082 0.061 0.048 0.041 0.039 0.041 0.048 0.061 0.082 0.122 0.203 0.452)))
(snd-display ";cepstrum 16 by ones: ~A" nrl))))
(for-each
@@ -35305,9 +35020,9 @@ EDITS: 1
(float-vector-scale! xim 0.0)
(mus-fft xrl xim len -1)
(float-vector-scale! xrl (/ 1.0 (float-vector-peak xrl)))
- (if (not (vequal rl xrl))
+ (if (not (mus-arrays-equal? rl xrl))
(snd-display ";mus-fft?? ~A: ~A ~A" len rl xrl))))
- (list 16 64 256 512))
+ '(16 64 256 512))
;; -------- walsh
@@ -35315,29 +35030,29 @@ EDITS: 1
(set! d0 (make-float-vector 8))
(set! (d0 0) 1.0)
(snd-transform walsh-transform d0)
- (if (not (vequal d0 (float-vector 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000)))
(snd-display ";walsh 1: ~A" d0))
(snd-transform walsh-transform d0)
- (if (not (vequal d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 8.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";walsh -1: ~A" d0))
(set! d0 (make-float-vector 8))
(set! (d0 1) 1.0)
(snd-transform walsh-transform d0)
- (if (not (vequal d0 (float-vector 1.000 -1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 1.000 -1.000 1.000 -1.000 1.000 -1.000 1.000 -1.000)))
(snd-display ";walsh 2: ~A" d0))
(snd-transform walsh-transform d0)
- (if (not (vequal d0 (float-vector 0.000 8.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 0.000 8.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";walsh -2: ~A" d0))
(set! d0 (make-float-vector 8))
(set! (d0 1) 1.0)
(set! (d0 0) 0.5)
(snd-transform walsh-transform d0)
- (if (not (vequal d0 (float-vector 1.500 -0.500 1.500 -0.500 1.500 -0.500 1.500 -0.500)))
+ (if (not (mus-arrays-equal? d0 (float-vector 1.500 -0.500 1.500 -0.500 1.500 -0.500 1.500 -0.500)))
(snd-display ";walsh 3: ~A" d0))
(snd-transform walsh-transform d0)
- (if (not (vequal d0 (float-vector 4.000 8.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 4.000 8.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";walsh -3: ~A" d0))
(set! d0 (make-float-vector 8))
@@ -35346,22 +35061,22 @@ EDITS: 1
(snd-transform walsh-transform d0)
(snd-transform walsh-transform d0)
(float-vector-scale! d0 (/ 1.0 8.0))
- (if (not (vequal d0 d1))
+ (if (not (mus-arrays-equal? d0 d1))
(snd-display ";walsh 4: ~A ~A" d0 d1))
(set! d0 (float-vector 1 1 1 -1 1 1 1 -1 1 1 1 -1 -1 -1 -1 1))
(set! d1 (snd-transform walsh-transform d0))
- (if (not (vequal d1 (float-vector 4.00 4.00 4.00 -4.00 4.00 4.00 4.00 -4.00 4.00 4.00 4.00 -4.00 -4.00 -4.00 -4.00 4.00)))
+ (if (not (mus-arrays-equal? d1 (float-vector 4.00 4.00 4.00 -4.00 4.00 4.00 4.00 -4.00 4.00 4.00 4.00 -4.00 -4.00 -4.00 -4.00 4.00)))
(snd-display ";walsh 5: ~A" d1))
(set! d0 (float-vector 1 0 0 -1 0 0 0 0 0 0 0 0 0 0 0 0))
(set! d1 (snd-transform walsh-transform d0))
- (if (not (vequal d1 (float-vector 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000)))
+ (if (not (mus-arrays-equal? d1 (float-vector 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000 0.000 2.000 2.000 0.000)))
(snd-display ";walsh 6: ~A" d1))
(set! d0 (float-vector 0.174 -0.880 -0.555 -0.879 0.038 0.696 -0.612 0.006 -0.613 0.334 -0.111 -0.821 0.130 0.030 -0.229 0.170))
(set! d1 (snd-transform walsh-transform d0))
- (if (not (vequal d1 (float-vector -3.122 -0.434 2.940 -0.468 -3.580 2.716 -0.178 -1.386 -0.902 0.638 1.196 1.848 -0.956 2.592 -1.046 2.926)))
+ (if (not (mus-arrays-equal? d1 (float-vector -3.122 -0.434 2.940 -0.468 -3.580 2.716 -0.178 -1.386 -0.902 0.638 1.196 1.848 -0.956 2.592 -1.046 2.926)))
(snd-display ";walsh 7: ~A" d1))
@@ -35370,33 +35085,33 @@ EDITS: 1
(set! d0 (make-float-vector 8))
(set! (d0 2) 1.0)
(snd-transform haar-transform d0)
- (if (not (vequal d0 (float-vector 0.354 0.354 -0.500 0.000 0.000 0.707 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 0.354 0.354 -0.500 0.000 0.000 0.707 0.000 0.000)))
(snd-display ";haar 1: ~A" d0))
(inverse-haar d0)
- (if (not (vequal d0 (float-vector 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 0.000 0.000 1.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";inverse haar 1: ~A" d0))
(set! d0 (make-float-vector 8))
(set! (d0 0) 1.0)
(snd-transform haar-transform d0)
- (if (not (vequal d0 (float-vector 0.354 0.354 0.500 0.000 0.707 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 0.354 0.354 0.500 0.000 0.707 0.000 0.000 0.000)))
(snd-display ";haar 2: ~A" d0))
(inverse-haar d0)
- (if (not (vequal d0 (float-vector 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? d0 (float-vector 1.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";inverse haar 2: ~A" d0))
(set! d0 (snd-transform haar-transform (float-vector -0.483 0.174 -0.880 -0.555 -0.879 0.038 0.696 -0.612)))
- (if (not (vequal d0 (float-vector -0.884 -0.349 0.563 -0.462 -0.465 -0.230 -0.648 0.925)))
+ (if (not (mus-arrays-equal? d0 (float-vector -0.884 -0.349 0.563 -0.462 -0.465 -0.230 -0.648 0.925)))
(snd-display ";haar 3: ~A" d0))
;; from "A Primer on Wavelets"
(let ((sq2 (sqrt 2.0)))
(set! d0 (snd-transform haar-transform (float-vector 4 6 10 12 8 6 5 5)))
- (if (not (vequal d0 (float-vector (* 14 sq2) (* 2 sq2) -6 2 (- sq2) (- sq2) sq2 0)))
+ (if (not (mus-arrays-equal? d0 (float-vector (* 14 sq2) (* 2 sq2) -6 2 (- sq2) (- sq2) sq2 0)))
(snd-display ";haar 4: ~A" d0))
(set! d0 (snd-transform haar-transform (float-vector 2 4 6 8 10 12 14 16)))
- (if (not (vequal d0 (float-vector (* 18 sq2) (* -8 sq2) -4 -4 (- sq2) (- sq2) (- sq2) (- sq2))))
+ (if (not (mus-arrays-equal? d0 (float-vector (* 18 sq2) (* -8 sq2) -4 -4 (- sq2) (- sq2) (- sq2) (- sq2))))
(snd-display ";haar 5: ~A" d0)))
(set! d0 (make-float-vector 8))
@@ -35407,7 +35122,7 @@ EDITS: 1
(copy d0 d1)
(snd-transform haar-transform d0)
(inverse-haar d0)
- (if (not (vequal d0 d1))
+ (if (not (mus-arrays-equal? d0 d1))
(snd-display ";inverse haar 6: ~A ~A" d0 d1))
@@ -35415,7 +35130,7 @@ EDITS: 1
;; test against fxt output
(set! d0 (snd-transform wavelet-transform (float-vector 1 1 0 0 0 0 0 0) 0)) ;"daub4"
- (if (not (vequal d0 (float-vector 0.625 0.375 -0.217 1.083 -0.354 0.000 0.000 0.354)))
+ (if (not (mus-arrays-equal? d0 (float-vector 0.625 0.375 -0.217 1.083 -0.354 0.000 0.000 0.354)))
(snd-display ";fxt wavelet 1: ~A" d0))
(for-each
@@ -35428,12 +35143,12 @@ EDITS: 1
(set! (d2 2) 1.0)
(wavelet d1 size 0 pwt (wts i))
(snd-transform wavelet-transform d2 i)
- (if (not (vequal d1 d2))
+ (if (not (mus-arrays-equal? d1 d2))
(snd-display ";wavelet ~D: ~A ~A" i d1 d2))
(wavelet d2 size -1 pwt (wts i))
(fill! d1 0.0)
(set! (d1 2) 1.0)
- (if (not (vequal d1 d2))
+ (if (not (mus-arrays-equal? d1 d2))
(if (memv i '(9 10))
(begin
(set! (d2 2) 0.0)
@@ -35453,9 +35168,9 @@ EDITS: 1
(set! d1 (copy d2))
(snd-transform wavelet-transform d2 i)
(wavelet d2 size -1 pwt (wts i))
- (if (not (vequal d1 d2))
+ (if (not (mus-arrays-equal? d1 d2))
(snd-display ";random wavelet ~D: ~A ~A" i d1 d2)))))
- (list 16 64))
+ '(16 64))
(set! *max-transform-peaks* 100)
(let ((ind (open-sound "oboe.snd")))
@@ -35664,16 +35379,14 @@ EDITS: 1
(not (= (length size) 3)))
(snd-display ";transform-framples of sonogram: ~A" size))))
(graph->ps "aaa.eps")
- (let ((old-colormap *colormap*))
- (if (and (defined? 'integer->colormap)
- (integer? old-colormap))
- (set! old-colormap (integer->colormap old-colormap)))
- (set! *colormap* black-and-white-colormap)
+ (if (and (defined? 'integer->colormap)
+ (integer? *colormap*))
+ (set! *colormap* (integer->colormap *colormap*)))
+ (let-temporarily ((*colormap* black-and-white-colormap))
(update-transform-graph)
(set! (transform-graph-type ind1 0) graph-as-spectrogram)
(update-transform-graph)
- (graph->ps "aaa.eps")
- (set! *colormap* old-colormap))
+ (graph->ps "aaa.eps"))
(close-sound ind1))
(let ((ind (new-sound "test.snd" :header-type mus-next :sample-type mus-ldouble)))
@@ -35722,7 +35435,7 @@ EDITS: 1
(close-sound ind))
(let ((v (dolph 16 2.5)))
- (if (not (vequal v (float-vector 0.097 0.113 0.221 0.366 0.536 0.709 0.860 0.963 1.000 0.963 0.860 0.709 0.536 0.366 0.221 0.113)))
+ (if (not (mus-arrays-equal? v (float-vector 0.097 0.113 0.221 0.366 0.536 0.709 0.860 0.963 1.000 0.963 0.860 0.709 0.536 0.366 0.221 0.113)))
(snd-display ";dolph 16 2.5 (dsp.scm): ~A" v)))
(let ((v (make-float-vector 8)))
@@ -35732,12 +35445,12 @@ EDITS: 1
(set! (v i) (mus-random 1.0))
(set! (v0 i) (float-vector-ref v i)))
(set! v (float-vector-scale! (dht (dht v)) (/ 1.0 8.0)))
- (if (not (vvequal v v0))
+ (if (not (vmus-arrays-equal? v v0))
(snd-display ";dht twice: ~A ~A" v v0)))
(fill! v 0.0)
(set! (v 1) 1.0)
(set! v (dht v))
- (if (not (vequal v (float-vector 1.000 1.414 1.000 0.000 -1.000 -1.414 -1.000 0.000)))
+ (if (not (mus-arrays-equal? v (float-vector 1.000 1.414 1.000 0.000 -1.000 -1.414 -1.000 0.000)))
(snd-display ";dht of pulse: ~A" v)))
(let ((ind (open-sound "oboe.snd")))
@@ -35780,16 +35493,16 @@ EDITS: 1
(close-sound ind))
(let ((v (float-vector-polynomial (float-vector 0.0 2.0) (float-vector 1.0 2.0))))
- (if (not (vequal v (float-vector 1.0 5.0)))
+ (if (not (mus-arrays-equal? v (float-vector 1.0 5.0)))
(snd-display ";float-vector-polynomial 0: ~A" v)))
(let ((v (float-vector-polynomial (float-vector 0 1 2) (float-vector 0 2 1))))
- (if (not (vequal v (float-vector 0.000 3.000 8.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 3.000 8.000)))
(snd-display ";float-vector-polynomial 1: ~A" v)))
(let ((v (float-vector-polynomial (float-vector 0 1 2) (float-vector 0 2 1 .5))))
- (if (not (vequal v (float-vector 0.000 3.500 12.000)))
+ (if (not (mus-arrays-equal? v (float-vector 0.000 3.500 12.000)))
(snd-display ";float-vector-polynomial 2: ~A" v)))
(let ((v (float-vector-polynomial (float-vector 0 1 2) (float-vector 1))))
- (if (not (vequal v (float-vector 1 1 1)))
+ (if (not (mus-arrays-equal? v (float-vector 1 1 1)))
(snd-display ";float-vector-polynomial 3: ~A" v)))
(let ((ind (open-sound "pistol.snd")))
(let ((mx (maxamp ind 0)))
@@ -35848,7 +35561,7 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i 10))
(set! (undata i) (fir-filter flt (undata i))))
- (if (not (vequal undata data))
+ (if (not (mus-arrays-equal? undata data))
(snd-display ";invert-filter: ~A" undata))))
(let ((coeffs (make-float-vector 6)))
@@ -35868,7 +35581,7 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i 20))
(set! (undata i) (fir-filter flt (undata i))))
- (if (not (vequal undata data))
+ (if (not (mus-arrays-equal? undata data))
(snd-display ";invert-filter (6): ~A" undata)))))
(let ((flt (make-volterra-filter (float-vector 1.0 .4) (float-vector .3 .2 .1)))
@@ -35878,7 +35591,7 @@ EDITS: 1
((= i 10))
(set! (data i) (volterra-filter flt x))
(set! x (if (= i 0) 0.5 0.0)))
- (if (not (vequal data (float-vector 0.000 0.575 0.250 0.025 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.575 0.250 0.025 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";volterra-filter: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0) (float-vector 1.0)))
@@ -35887,7 +35600,7 @@ EDITS: 1
(x 1.0 0.0))
((= i 10))
(set! (data i) (volterra-filter flt x)))
- (if (not (vequal data (float-vector 2.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 2.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";volterra-filter x + x^2: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0) (float-vector 1.0)))
@@ -35896,7 +35609,7 @@ EDITS: 1
(x 1.0 (- x 0.1)))
((= i 10))
(set! (data i) (volterra-filter flt x)))
- (if (not (vequal data (float-vector 2.000 1.710 1.440 1.190 0.960 0.750 0.560 0.390 0.240 0.110)))
+ (if (not (mus-arrays-equal? data (float-vector 2.000 1.710 1.440 1.190 0.960 0.750 0.560 0.390 0.240 0.110)))
(snd-display ";volterra-filter x + x^2 by -0.1: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0 0.5) (float-vector 1.0)))
@@ -35905,7 +35618,7 @@ EDITS: 1
(x 1.0 0.0))
((= i 10))
(set! (data i) (volterra-filter flt x)))
- (if (not (vequal data (float-vector 2.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 2.000 0.500 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";volterra-filter x + .5x(n-1) + x^2: ~A" data)))
(let ((flt (make-volterra-filter (float-vector 1.0 0.5) (float-vector 1.0 0.6)))
@@ -35914,7 +35627,7 @@ EDITS: 1
(x 0.9 0.0))
((= i 10))
(set! (data i) (volterra-filter flt x)))
- (if (not (vequal data (float-vector 1.710 0.936 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 1.710 0.936 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";volterra-filter x + .5x(n-1) + x^2 + 0.6: ~A" data)))
@@ -35942,8 +35655,8 @@ EDITS: 1
(d1 (make-float-vector 8)))
(set! (d0 2) 1.0)
(let ((vals (fractional-fourier-transform d0 d1 8 1.0)))
- (if (not (and (vequal (car vals) (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000))
- (vequal (cadr vals) (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
+ (if (not (and (mus-arrays-equal? (car vals) (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000))
+ (mus-arrays-equal? (cadr vals) (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
(snd-display ";fractional-fft: ~A?" vals))))
(let ((d0 (make-float-vector 8))
@@ -35953,33 +35666,33 @@ EDITS: 1
((= i 8))
(set! (d0 i) (real-part (vector-ref val i)))
(set! (d1 i) (imag-part (vector-ref val i))))
- (if (not (and (vequal d0 (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000))
- (vequal d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
+ (if (not (and (mus-arrays-equal? d0 (float-vector 1.000 0.000 -1.000 -0.000 1.000 0.000 -1.000 -0.000))
+ (mus-arrays-equal? d1 (float-vector 0.000 1.000 0.000 -1.000 0.000 1.000 0.000 -1.000))))
(snd-display ";z-transform: ~A ~A?" d0 d1))))
(let ((v1 (make-float-vector 16)))
(set! (v1 0) 1.0)
(let ((res (z-transform v1 16 0.5)))
- (if (not (vequal res (make-float-vector 16 1.0)))
+ (if (not (mus-arrays-equal? res (make-float-vector 16 1.0)))
(snd-display ";z 0.5 0=1: ~A" res)))
(let ((res (z-transform v1 16 -1.0)))
- (if (not (vequal res (make-float-vector 16 1.0)))
+ (if (not (mus-arrays-equal? res (make-float-vector 16 1.0)))
(snd-display ";z -1.0 0=1: ~A" res)))
(set! (v1 0) 0.0)
(set! (v1 1) 1.0)
(let ((res (z-transform v1 16 0.5)))
- (if (not (vequal res (float-vector 1.000 0.500 0.250 0.125 0.062 0.031 0.016 0.008 0.004 0.002 0.001 0.0 0.0 0.0 0.0 0.0)))
+ (if (not (mus-arrays-equal? res (float-vector 1.000 0.500 0.250 0.125 0.062 0.031 0.016 0.008 0.004 0.002 0.001 0.0 0.0 0.0 0.0 0.0)))
(snd-display ";z 0.5 1=1: ~A" res)))
(let ((res (z-transform v1 16 2.0)))
- (if (not (vequal res (float-vector 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0
+ (if (not (mus-arrays-equal? res (float-vector 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0
2048.0 4096.0 8192.0 16384.0 32768.0)))
(snd-display ";z 2.0 1=1: ~A" res)))
(set! (v1 2) 1.0)
(let ((res (z-transform v1 16 0.5)))
- (if (not (vequal res (float-vector 2.0 0.75 0.3125 0.140 0.0664 0.0322 0.0158 0.00787 0.0039 0.0019 0 0 0 0 0 0)))
+ (if (not (mus-arrays-equal? res (float-vector 2.0 0.75 0.3125 0.140 0.0664 0.0322 0.0158 0.00787 0.0039 0.0019 0 0 0 0 0 0)))
(snd-display ";z 0.5 1=1 2=1: ~A" res)))
(let ((res (z-transform v1 16 2.0)))
- (if (not (vequal res (float-vector 2.0 6.0 20.0 72.0 272.0 1056.0 4160.0 16512.0 65792.0
+ (if (not (mus-arrays-equal? res (float-vector 2.0 6.0 20.0 72.0 272.0 1056.0 4160.0 16512.0 65792.0
262656.0 1049600.0 4196352.0 16781312.0 67117056.0 268451840.0 1073774592.0)))
(snd-display ";z 2.0 1=1 2=1: ~A" res)))
(do ((i 0 (+ i 1))
@@ -35987,7 +35700,7 @@ EDITS: 1
((= i 16))
(float-vector-set! v1 i j))
(let ((res (z-transform v1 16 1.0)))
- (if (not (vequal res (make-float-vector 16 (/ 1.0 (- 1.0 0.4))))) ; this is confusing
+ (if (not (mus-arrays-equal? res (make-float-vector 16 (/ 1.0 (- 1.0 0.4))))) ; this is confusing
(snd-display ";z 1 0.4g: ~A" res))))
(let ((ind (open-sound "oboe.snd")))
@@ -36011,12 +35724,11 @@ EDITS: 1
(let ((temp (data j)))
(set! (data j) (data i))
(set! (data i) temp)))
- (let ((m (/ n 2)))
- (do ()
- ((or (< m 2) (< j m)))
- (set! j (- j m))
- (set! m (/ m 2)))
- (set! j (+ j m))))
+ (do ((m (/ n 2)))
+ ((not (<= 2 m j))
+ (set! j (+ j m)))
+ (set! j (- j m))
+ (set! m (/ m 2))))
(do ((ipow (floor (log n 2)))
(prev 1)
(lg 0 (+ lg 1))
@@ -36055,8 +35767,7 @@ EDITS: 1
(set! (rl i) tempr)
(set! (im i) tempi)))
(do ((m (/ n 2)))
- ((or (< m 2)
- (< j m))
+ ((not (<= 2 m j))
(set! j (+ j m)))
(set! j (- j m))
(set! m (/ m 2))))
@@ -36221,10 +35932,8 @@ EDITS: 1
;; samples 1000 and 2000
(size (length low-data))
(samps (- right left))
- (left-offset (max 0 (- 1000 left)))
- (left-bin (round (/ (* size left-offset) samps)))
- (right-offset (- (min 2000 right) left))
- (right-bin (round (/ (* size right-offset) samps)))
+ (left-bin (round (/ (* size (max 0 (- 1000 left))) samps)))
+ (right-bin (round (/ (* size (- (min 2000 right) left)) samps)))
(new-low-data (float-vector-subseq low-data left-bin right-bin))
(new-high-data (float-vector-subseq high-data left-bin right-bin))
(cr (make-cairo (car (channel-widgets snd chn)))))
@@ -36335,14 +36044,14 @@ EDITS: 1
(set! (selection-framples ns1 1) 30000)
(show-selection)
(if (not (and (eqv? (left-sample ns 0) 10000)
- (member (right-sample ns 0) '(39999 39998))
+ (memv (right-sample ns 0) '(39999 39998))
(eqv? (left-sample ns1 0) 10000)
- (member (right-sample ns1 0) '(39999 39998))
+ (memv (right-sample ns1 0) '(39999 39998))
(eqv? (left-sample ns1 1) 10000)
- (member (right-sample ns1 1) '(39999 39998))))
+ (memv (right-sample ns1 1) '(39999 39998))))
(snd-display ";show-selection 1234.snd: ~A" (list (left-sample ns 0) (right-sample ns 0)
- (left-sample ns1 0) (right-sample ns1 0)
- (left-sample ns1 1) (right-sample ns1 1))))
+ (left-sample ns1 0) (right-sample ns1 0)
+ (left-sample ns1 1) (right-sample ns1 1))))
(close-sound ns1)
(close-sound ns)))
@@ -36353,18 +36062,17 @@ EDITS: 1
(if (not (= (pe 'current-env) 0)) (snd-display ";power-env seg: ~A" (pe 'current-env)))
)
- (let ((old-srate *clm-srate*))
+ (let-temporarily ((*clm-srate* 22050))
(set! *print-length* (max *print-length* 48))
- (set! *clm-srate* 22050)
(let ((ind (new-sound :size 33 :srate 22050)))
(map-channel (lambda (y) 1.0))
(let ((pe (make-power-env '(0 0 32.0 1 1 0.0312 2 0 1) :duration (/ 34.0 22050.0))))
(map-channel (lambda (y) (* y (power-env pe))))
- (if (not (or (vequal1 (channel->float-vector)
+ (if (not (or (mus-arrays-equal?1 (channel->float-vector)
(float-vector 0.000 0.008 0.017 0.030 0.044 0.063 0.086 0.115 0.150 0.194 0.249
0.317 0.402 0.507 0.637 0.799 1.000 0.992 0.983 0.971 0.956 0.937
0.914 0.885 0.850 0.806 0.751 0.683 0.598 0.493 0.363 0.201 0.000))
- (vequal1 (channel->float-vector)
+ (mus-arrays-equal?1 (channel->float-vector)
(float-vector 0.000 0.008 0.019 0.032 0.049 0.070 0.097 0.130 0.173 0.226 0.293
0.377 0.484 0.618 0.787 1.000 0.992 0.981 0.968 0.951 0.930 0.903
0.870 0.828 0.774 0.707 0.623 0.516 0.382 0.213 0.000 0.000 0.000))))
@@ -36372,7 +36080,7 @@ EDITS: 1
(map-channel (lambda (y) 1.0))
(let ((pe (make-power-env '(0 0 1.0 1 1 0.0 2 0 1 3 0 1) :duration (/ 34.0 22050.0))))
(map-channel (lambda (y) (* y (power-env pe))))
- (if (not (vequal1 (channel->float-vector)
+ (if (not (mus-arrays-equal?1 (channel->float-vector)
(float-vector 0.000 0.100 0.200 0.300 0.400 0.500 0.600 0.700 0.800 0.900 1.000
1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 0.000 0.000
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
@@ -36380,40 +36088,39 @@ EDITS: 1
(map-channel (lambda (y) 1.0))
(let ((pe (make-power-env '(0 0 .01 1 1 1) :duration (/ 34.0 22050.0))))
(map-channel (lambda (y) (* y (power-env pe))))
- (if (not (or (vequal1 (channel->float-vector)
+ (if (not (or (mus-arrays-equal?1 (channel->float-vector)
(float-vector 0.000 0.132 0.246 0.346 0.432 0.507 0.573 0.630 0.679 0.722 0.760
0.792 0.821 0.845 0.867 0.886 0.902 0.916 0.928 0.939 0.948 0.956
0.963 0.969 0.975 0.979 0.983 0.987 0.990 0.992 0.995 0.997 0.998))
- (vequal1 (channel->float-vector)
+ (mus-arrays-equal?1 (channel->float-vector)
(float-vector 0.000 0.135 0.253 0.354 0.442 0.518 0.584 0.641 0.691 0.733 0.771
0.803 0.830 0.855 0.875 0.893 0.909 0.923 0.934 0.945 0.953 0.961
0.968 0.973 0.978 0.982 0.986 0.987 0.990 0.992 0.995 0.997 0.998))))
(snd-display ";power-env .01: ~A" (channel->float-vector))))
(let ((name (file-name ind)))
(close-sound ind)
- (if (file-exists? name) (delete-file name))))
- (set! *clm-srate* old-srate))
+ (if (file-exists? name) (delete-file name)))))
(let ((ind (new-sound "tmp.snd" 1 22050 mus-ldouble mus-next :size 50)))
(set! (sample 3) 1.0)
(filter-channel (float-vector .5 1.0 .5) 3)
(let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 0.500 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.000 0.000 0.500 1.000 0.500 0.000 0.000 0.000 0.000)))
(snd-display ";filter (sym 3): ~A" data)))
(undo)
(filter-channel (float-vector .5 1.0 .25) 3)
(let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 0.250 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.000 0.000 0.500 1.000 0.250 0.000 0.000 0.000 0.000)))
(snd-display ";filter (3): ~A" data)))
(undo)
(filter-channel (float-vector .5 1.0 1.0 .5) 4)
(let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 1.000 0.500 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.000 0.000 0.500 1.000 1.000 0.500 0.000 0.000 0.000)))
(snd-display ";filter (sym 4): ~A" data)))
(undo)
(filter-channel (float-vector .5 1.0 1.0 .25) 4)
(let ((data (channel->float-vector 0 10)))
- (if (not (vequal data (float-vector 0.000 0.000 0.000 0.500 1.000 1.000 0.250 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? data (float-vector 0.000 0.000 0.000 0.500 1.000 1.000 0.250 0.000 0.000 0.000)))
(snd-display ";filter (4): ~A" data)))
(undo)
(close-sound ind))
@@ -36421,11 +36128,11 @@ EDITS: 1
(new-sound "tmp.snd" 1 22050 mus-ldouble mus-next #f 100)
(set! (sample 10) 0.5)
(filter-sound (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
(snd-display ";filter-sound 1 0 1: ~A" (channel->float-vector 5 10)))
(undo)
(filter-channel (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
(snd-display ";filter-channel (v) 1 0 1: ~A" (channel->float-vector 5 10)))
(undo)
(filter-sound '(0 1 1 1) 100)
@@ -36440,50 +36147,51 @@ EDITS: 1
(set! happy #f)))))
(undo)
(filter-sound '(0 1 1 1) 1000)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
(snd-display ";filter-sound 1 (1000): ~A" (channel->float-vector 5 10)))
(undo)
(make-selection 5 15)
(filter-selection '(0 1 1 1) 100)
- (if (not (or (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 11))
- (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111))))
+ (if (not (member (edit-fragment 2)
+ '(("filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 11)
+ ("filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111))))
(snd-display ";filter-selection truncated: ~S" (edit-fragment 2)))
(undo)
(filter-selection '(0 1 1 1) 100 #f)
- (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111)))
+ (if (not (equal? (edit-fragment 2) '("filter-selection '(0.000 1.000 1.000 1.000) 100" "set" 5 111)))
(snd-display ";filter-selection not truncated: ~S" (edit-fragment 2)))
- (if (not (vequal (channel->float-vector 50 10) (float-vector -0.016 0.018 -0.021 0.024 -0.029 0.035 -0.045 0.064 -0.106 0.318)))
+ (if (not (mus-arrays-equal? (channel->float-vector 50 10) (float-vector -0.016 0.018 -0.021 0.024 -0.029 0.035 -0.045 0.064 -0.106 0.318)))
(snd-display ";filter-selection no trunc: ~A" (channel->float-vector 50 10)))
(undo)
(filter-selection '(0 1 1 1) 1024 #t)
- (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 11)))
+ (if (not (equal? (edit-fragment 2) '("filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 11)))
(snd-display ";filter-selection truncated (1000): ~S" (edit-fragment 2)))
(if (fneq (maxamp) 0.0) (snd-display ";filter-selection 1000 untrunc? ~A" (maxamp)))
(undo)
(filter-selection '(0 1 1 1) 1024 #f)
- (if (not (equal? (edit-fragment 2) (list "filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 1035)))
+ (if (not (equal? (edit-fragment 2) '("filter-selection '(0.000 1.000 1.000 1.000) 1024" "set" 5 1035)))
(snd-display ";filter-selection not truncated (1000): ~S" (edit-fragment 2)))
(if (fneq (maxamp) 0.318) (snd-display ";filter-selection 1000 no trunc? ~A" (maxamp)))
- (if (not (vequal (channel->float-vector 517 10) (float-vector 0.035 -0.045 0.064 -0.106 0.318 0.318 -0.106 0.064 -0.045 0.035)))
+ (if (not (mus-arrays-equal? (channel->float-vector 517 10) (float-vector 0.035 -0.045 0.064 -0.106 0.318 0.318 -0.106 0.064 -0.045 0.035)))
(snd-display ";filter-selection 1000 no trunc: ~A" (channel->float-vector 505 10)))
(undo)
(filter-channel '(0 1 1 1) 10)
- (if (not (vequal (channel->float-vector 10 10) (float-vector 0.008 -0.025 0.050 -0.098 0.316 0.316 -0.098 0.050 -0.025 0.008)))
+ (if (not (mus-arrays-equal? (channel->float-vector 10 10) (float-vector 0.008 -0.025 0.050 -0.098 0.316 0.316 -0.098 0.050 -0.025 0.008)))
(snd-display ";filter-channel 10: ~A" (channel->float-vector 10 10)))
(undo)
(filter-channel '(0 1 1 1) 1000)
- (if (not (vequal (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
(snd-display ";filter-channel 1 (1000): ~A" (channel->float-vector 5 10)))
(undo)
(filter-channel '(0 1 1 0) 10)
- (if (not (vequal (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0.005 0.010 0.006 0.038 0.192 0.192 0.038 0.006 0.010 0.005
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";filter-channel lp: ~A ~A ~A" (channel->float-vector 0 10) (channel->float-vector 10 10) (channel->float-vector 20 10)))
(undo)
(filter-channel '(0 1 1 0) 10 0 20 #f #f #f #f)
- (if (not (vequal (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30) (float-vector 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0.005 0.010 0.006 0.038 0.192 0.192 0.038 0.006 0.010 0.005
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000)))
(snd-display ";filter-channel lp no trunc: ~A ~A ~A" (channel->float-vector 0 10) (channel->float-vector 10 10) (channel->float-vector 20 10)))
@@ -36495,42 +36203,42 @@ EDITS: 1
(set! (sample 5 ind 1) -0.5)
(set! (sync ind) 1)
(filter-sound (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
(snd-display ";(2) filter-sound 1 0 1: ~A" (channel->float-vector 5 10)))
- (if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
(snd-display ";(2) filter-sound 1 0 2: ~A" (channel->float-vector 0 10 ind 1)))
(undo)
(filter-sound '(0 1 1 1) 1000)
- (if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.000 0.000 0.000)))
(snd-display ";(2) filter-sound 1 (1000): ~A" (channel->float-vector 5 10)))
- (if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 0.000 0.000 0.000)))
(snd-display ";(2) filter-sound 2 (1000): ~A" (channel->float-vector 0 10)))
(undo)
(make-selection 0 20)
(filter-selection (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
(snd-display ";(2) filter-selection 1 0 1: ~A" (channel->float-vector 5 10)))
- (if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
(snd-display ";(2) filter-selection 1 0 2: ~A" (channel->float-vector 0 10 ind 1)))
(undo)
(set! (sync ind) 0)
(filter-selection (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
(snd-display ";(2) filter-selection 1 0 1 (no sync): ~A" (channel->float-vector 5 10)))
- (if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 -0.500 0.000 0.000)))
(snd-display ";(2) filter-selection 1 0 2 (no sync): ~A" (channel->float-vector 0 10 ind 1)))
(undo 1 ind 0)
(undo 1 ind 1)
(if (not (= (edit-position ind 0) 1)) (snd-display ";edpos filter-sel undo: ~A" (edit-position ind 0)))
(if (not (= (edit-position ind 1) 1)) (snd-display ";edpos filter-sel undo 1: ~A" (edit-position ind 1)))
(filter-sound (float-vector 1.0 0.0 1.0) 3)
- (if (not (vequal (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 5 10 ind 0) (float-vector 0.000 0.000 0.000 0.000 0.000 0.500 0.000 0.500 0.000 0.000)))
(snd-display ";(2) filter-sound 1 0 1 no sync: ~A" (channel->float-vector 5 10)))
- (if (not (vequal (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 0.000 0.000 0.000)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 10 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000 -0.500 0.000 0.000 0.000 0.000)))
(snd-display ";(2) filter-sound 1 0 2 no sync: ~A" (channel->float-vector 0 10 ind 1)))
(undo 1 ind 0)
(filter-channel '(0 1 1 0) 10 #f #f ind 1)
- (if (not (vequal (channel->float-vector 0 30 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000; 0.000 0.000 0.000 0.000 0.000
+ (if (not (mus-arrays-equal? (channel->float-vector 0 30 ind 1) (float-vector 0.000 0.000 0.000 0.000 0.000; 0.000 0.000 0.000 0.000 0.000
-0.005 -0.010 -0.006 -0.038 -0.192 -0.192 -0.038 -0.006 -0.010 -0.005
0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000
0 0 0 0 0)))
@@ -36906,43 +36614,43 @@ EDITS: 1
(map-channel (lambda (y) 1.0))
(env-channel-with-base '(0 0 1 1) 1.0)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 0.0 0.05 0.10 0.15 0.20 0.25 0.30 0.35 0.40 0.45 0.50 0.55 0.60 0.65 0.70 0.75 0.80 0.85 0.90 0.95)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.05 0.10 0.15 0.20 0.25 0.30 0.35 0.40 0.45 0.50 0.55 0.60 0.65 0.70 0.75 0.80 0.85 0.90 0.95)))
(snd-display ";env-chan 1.0: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1 2 1 3 0) 0.0)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)))
(snd-display ";env-chan 0.0: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 100.0)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 0.0 0.003 0.006 0.010 0.015 0.022 0.030 0.041 0.054 0.070 0.091 0.117 0.150 0.191 0.244 0.309 0.392 0.496 0.627 0.792)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.003 0.006 0.010 0.015 0.022 0.030 0.041 0.054 0.070 0.091 0.117 0.150 0.191 0.244 0.309 0.392 0.496 0.627 0.792)))
(snd-display ";env-chan 100.0: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 0.01)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 0.0 0.208 0.373 0.504 0.608 0.691 0.756 0.809 0.850 0.883 0.909 0.930 0.946 0.959 0.970 0.978 0.985 0.990 0.994 0.997)))
+ (if (not (mus-arrays-equal? data (float-vector 0.0 0.208 0.373 0.504 0.608 0.691 0.756 0.809 0.850 0.883 0.909 0.930 0.946 0.959 0.970 0.978 0.985 0.990 0.994 0.997)))
(snd-display ";env-chan 0.01: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 1.0 5 10)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.0 1.0 1.0 1.0 1.0 1.0)))
+ (if (not (mus-arrays-equal? data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.111 0.222 0.333 0.444 0.556 0.667 0.778 0.889 1.0 1.0 1.0 1.0 1.0 1.0)))
(snd-display ";env-chan 1.0 seg: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1 2 1 3 0) 0.0 5 10)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)))
+ (if (not (mus-arrays-equal? data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)))
(snd-display ";env-chan 0.0 seg: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 100.0 5 10)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.007 0.018 0.037 0.068 0.120 0.208 0.353 0.595 1.0 1.0 1.0 1.0 1.0 1.0)))
+ (if (not (mus-arrays-equal? data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.007 0.018 0.037 0.068 0.120 0.208 0.353 0.595 1.0 1.0 1.0 1.0 1.0 1.0)))
(snd-display ";env-chan 100.0 seg: ~A" data)))
(undo)
(env-channel-with-base '(0 0 1 1) 0.01 5 10)
(let ((data (channel->float-vector 0 20)))
- (if (not (vequal data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.405 0.647 0.792 0.880 0.932 0.963 0.982 0.993 1.0 1.0 1.0 1.0 1.0 1.0)))
+ (if (not (mus-arrays-equal? data (float-vector 1.0 1.0 1.0 1.0 1.0 0.0 0.405 0.647 0.792 0.880 0.932 0.963 0.982 0.993 1.0 1.0 1.0 1.0 1.0 1.0)))
(snd-display ";env-chan 0.01 seg: ~A" data)))
(undo)
(close-sound snd))
@@ -37184,7 +36892,7 @@ EDITS: 1
(insert-float-vector (make-float-vector 5 .1) 2)
(if (not (= (framples ind) 15)) (snd-display ";insert-float-vector len: ~A" (framples ind)))
(let ((vals (channel->float-vector 0 #f ind 0)))
- (if (not (vequal vals (float-vector 1 1 .1 .1 .1 .1 .1 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? vals (float-vector 1 1 .1 .1 .1 .1 .1 1 1 1 1 1 1 1 1)))
(snd-display ";insert-float-vector vals: ~A" vals)))
(let ((tag (catch #t (lambda () (insert-float-vector 32)) (lambda args (car args)))))
@@ -37193,7 +36901,7 @@ EDITS: 1
(insert-float-vector (make-float-vector 1 1.5) 0 1 ind 0)
(if (not (= (framples ind) 16)) (snd-display ";insert-float-vector 1 len: ~A" (framples ind)))
(let ((vals (channel->float-vector 0 #f ind 0)))
- (if (not (vequal vals (float-vector 1.5 1 1 .1 .1 .1 .1 .1 1 1 1 1 1 1 1 1)))
+ (if (not (mus-arrays-equal? vals (float-vector 1.5 1 1 .1 .1 .1 .1 .1 1 1 1 1 1 1 1 1)))
(snd-display ";insert-float-vector 1 vals: ~A" vals)))
(close-sound ind))
@@ -37206,26 +36914,26 @@ EDITS: 1
(insert-float-vector (make-float-vector 20 .1) 2 2 ind 2)
(if (not (= (framples ind 0) 5)) (snd-display ";4chn insert-float-vector (0) len: ~A" (framples ind 0)))
(if (not (= (framples ind 2) 7)) (snd-display ";4chn insert-float-vector (2) len: ~A" (framples ind 2)))
- (if (not (vequal (channel->float-vector 0 7 ind 0) (float-vector .4 .4 .4 .4 .4 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 0) (float-vector .4 .4 .4 .4 .4 0 0)))
(snd-display ";4chn insert-float-vector 0: ~A" (channel->float-vector 0 7 ind 0)))
- (if (not (vequal (channel->float-vector 0 7 ind 1) (float-vector .5 .5 .5 .5 .5 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 1) (float-vector .5 .5 .5 .5 .5 0 0)))
(snd-display ";4chn insert-float-vector 1: ~A" (channel->float-vector 0 7 ind 1)))
- (if (not (vequal (channel->float-vector 0 7 ind 2) (float-vector .6 .6 .1 .1 .6 .6 .6)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 2) (float-vector .6 .6 .1 .1 .6 .6 .6)))
(snd-display ";4chn insert-float-vector 2: ~A" (channel->float-vector 0 7 ind 2)))
- (if (not (vequal (channel->float-vector 0 7 ind 3) (float-vector .7 .7 .7 .7 .7 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 3) (float-vector .7 .7 .7 .7 .7 0 0)))
(snd-display ";4chn insert-float-vector 3: ~A" (channel->float-vector 0 7 ind 3)))
(insert-float-vector (make-float-vector 20 .2) 0 2 ind 0)
(if (not (= (framples ind 0) 7)) (snd-display ";4chn insert-float-vector (0 0) len: ~A" (framples ind 0)))
(if (not (= (framples ind 1) 5)) (snd-display ";4chn insert-float-vector (0 1) len: ~A" (framples ind 1)))
(if (not (= (framples ind 2) 7)) (snd-display ";4chn insert-float-vector (2 2) len: ~A" (framples ind 2)))
- (if (not (vequal (channel->float-vector 0 7 ind 0) (float-vector .2 .2 .4 .4 .4 .4 .4)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 0) (float-vector .2 .2 .4 .4 .4 .4 .4)))
(snd-display ";4chn insert-float-vector 1 0: ~A" (channel->float-vector 0 7 ind 0)))
- (if (not (vequal (channel->float-vector 0 7 ind 1) (float-vector .5 .5 .5 .5 .5 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 1) (float-vector .5 .5 .5 .5 .5 0 0)))
(snd-display ";4chn insert-float-vector 1 1: ~A" (channel->float-vector 0 7 ind 1)))
- (if (not (vequal (channel->float-vector 0 7 ind 2) (float-vector .6 .6 .1 .1 .6 .6 .6)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 2) (float-vector .6 .6 .1 .1 .6 .6 .6)))
(snd-display ";4chn insert-float-vector 1 2: ~A" (channel->float-vector 0 7 ind 2)))
- (if (not (vequal (channel->float-vector 0 7 ind 3) (float-vector .7 .7 .7 .7 .7 0 0)))
+ (if (not (mus-arrays-equal? (channel->float-vector 0 7 ind 3) (float-vector .7 .7 .7 .7 .7 0 0)))
(snd-display ";4chn insert-float-vector 1 3: ~A" (channel->float-vector 0 7 ind 3)))
(revert-sound ind)
@@ -37291,7 +36999,7 @@ EDITS: 1
(revert-sound ind1)
(set! (sample 100 ind0 0) 1.0)
(let* ((diff (snddiff ind0 0 ind1 0))
- (info (and diff (list? diff) (= (length diff) 2) (= (length (caadr diff)) 3) (caadr diff))))
+ (info (and (list? diff) (= (length diff) 2) (= (length (caadr diff)) 3) (caadr diff))))
(if (or (not (eq? (car diff) 'differences))
(not info)
(not (= (car info) 100))
@@ -37773,8 +37481,7 @@ EDITS: 1
(g1 (make-oscil 1000)))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (let* ((x (oscil g0))
- (y x))
+ (let ((y (oscil g0)))
(float-vector-set! fv i (+ y (oscil g1)))))))
(test (fv35) (float-vector 0.0 0.2839886359152535 0.5622222266633099 0.8290623533805906))
@@ -37785,9 +37492,7 @@ EDITS: 1
(x 1.0))
(do ((i 0 (+ i 1)))
((= i 4) (and (positive? x) fv))
- (let ((x (oscil g0))
- (y x))
- (float-vector-set! fv i (+ y (oscil g1)))))))
+ (float-vector-set! fv i (+ 1.0 (oscil g1))))))
(test (fv36) (float-vector 1.0 1.141994317957627 1.281111113331655 1.414531176690295))
(define (fv37)
@@ -37873,7 +37578,7 @@ EDITS: 1
(if (pair? s-args)
(for-each-permutation (lambda args (apply permute op args)) s-args)))
(list 'x '(oscil g0) 2.0 '(oscil g1) 'y)))
- (list '+ '* '-))
+ '(+ * -))
(for-each-subset
(lambda s-args
@@ -38013,16 +37718,6 @@ EDITS: 1
(float-vector-set! fv i (* (env e) (oscil g))))))
(test (fv57) (float-vector 0.0 0.03549857948940669 0.1405555566658275 0.3108983825177215))
- (define (fv58)
- (let ((fv (make-float-vector 4))
- (g (make-oscil 1000)))
- (do ((i 0 (+ i 1)))
- ((= i 4) fv)
- (let ((j i)) ; no rf here
- (float-vector-set! fv j (oscil g))))))
-
- (test (fv58) (float-vector 0.0 0.1419943179576268 0.2811111133316549 0.4145311766902953))
-
(define (fv59)
(let ((fv (make-float-vector 4))
(g (make-oscil 1000)))
@@ -38254,7 +37949,7 @@ EDITS: 1
(define (fv85)
(let ((fv1 (make-float-vector 4 1.5))
- (fv2 (make-float-vector 4 0.0)))
+ (fv2 (make-float-vector 4)))
(do ((i 0 (+ i 1)))
((= i 10) fv2)
(float-vector-add! fv2 fv1))))
@@ -38334,10 +38029,8 @@ EDITS: 1
(mus-close sf)
(list (file->array "fmv.snd" 0 0 4 fv1)
(file->array "fmv.snd" 1 0 4 fv2))))
- (let ((old-fudge (*s7* 'morally-equal-float-epsilon)))
- (set! (*s7* 'morally-equal-float-epsilon) 1e-5)
- (test (fv92) (list (make-float-vector 4 .1) (make-float-vector 4 .2)))
- (set! (*s7* 'morally-equal-float-epsilon) old-fudge))
+ (let-temporarily (((*s7* 'morally-equal-float-epsilon) 1e-5))
+ (test (fv92) (list (make-float-vector 4 .1) (make-float-vector 4 .2))))
(define (fv93)
(let ((sf (make-frample->file "fmv.snd" 2 mus-lfloat mus-riff "this is a comment"))
@@ -38350,11 +38043,9 @@ EDITS: 1
(mus-close sf)
(list (file->array "fmv.snd" 0 0 4 fv1)
(file->array "fmv.snd" 1 0 4 fv2))))
- (let ((old-fudge (*s7* 'morally-equal-float-epsilon)))
- (set! (*s7* 'morally-equal-float-epsilon) 1e-5)
+ (let-temporarily (((*s7* 'morally-equal-float-epsilon) 1e-5))
(test (fv93) (list (float-vector .02 .04 .08 .16)
- (float-vector .04 .08 .16 .32)))
- (set! (*s7* 'morally-equal-float-epsilon) old-fudge))
+ (float-vector .04 .08 .16 .32))))
(define (fv94)
(do ((fv0 (float-vector 0 1 2 3 4 5))
@@ -38379,9 +38070,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (even? i)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (even? i) + -) i 10.0))))
(test (fv95) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv95a)
@@ -38389,19 +38078,15 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (odd? i)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (odd? i) + -) i 10.0))))
(test (fv95a) (float-vector -10.0 11.0 -8.0 13.0))
(define (fv95b)
(do ((fv (make-float-vector 4))
(i 0 (+ i 1))
(x 0 (+ x 1)))
- ((= i 4) fv)
- (float-vector-set! fv i (if (not (odd? i))
- (+ i 10.0)
- (- i 10.0)))))
+ ((= i 4) (and (positive? x) fv))
+ (float-vector-set! fv i ((if (not (odd? i)) + -) i 10.0))))
(test (fv95b) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv96)
@@ -38411,9 +38096,7 @@ EDITS: 1
(x 0 (+ x 1)))
((= i 4) (and (positive? x) (list fv fv1)))
(float-vector-set! fv1 i 3.0)
- (float-vector-set! fv i (if (even? i)
- (+ i 10.0)
- (- i 10.0)))
+ (float-vector-set! fv i ((if (even? i) + -) i 10.0))
(float-vector-set! fv1 i (+ (float-vector-ref fv1 i) 1.0))))
(test (fv96) (list (float-vector 10.0 -9.0 12.0 -7.0)
(float-vector 4.0 4.0 4.0 4.0)))
@@ -38445,9 +38128,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (zero? i)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (zero? i) + -) i 10.0))))
(test (fv99) (float-vector 10.0 -9.0 -8.0 -7.0))
(define (fv100)
@@ -38455,16 +38136,14 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (zero? (modulo i 2))
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (zero? (modulo i 2)) + -) i 10.0))))
(test (fv100) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv101)
(do ((ctr 0)
(i 0 (+ i 1))
(x 0 (+ x 1)))
- ((= i 4) (and x ctr))
+ ((= i 4) (and (positive? x) ctr))
(if (zero? (modulo i 2))
(set! ctr (+ ctr 1)))))
(test (fv101) 2)
@@ -38517,7 +38196,7 @@ EDITS: 1
(for-each-permutation
do-permute
(list a b c)))
- (list 0 4 1 2 0.0 4.0 1.0 2.0 1/2 1+i 2/3 #\a "hi" #f)))
+ '(0 4 1 2 0.0 4.0 1.0 2.0 1/2 1+i 2/3 #\a "hi" #f)))
(define (fv107)
(do ((g0 (make-hash-table))
@@ -38615,9 +38294,7 @@ EDITS: 1
(do ((i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (oscil? g)
- (+ i 10.0)
- (- i 10.0))))))
+ (float-vector-set! fv i ((if (oscil? g) + -) i 10.0)))))
(test (fv116) (float-vector 10.0 11.0 12.0 13.0))
(define (fv117)
@@ -38625,9 +38302,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (even? (round i))
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (even? (round i)) + -) i 10.0))))
(test (fv117) (float-vector 10.0 -9.0 12.0 -7.0))
(define (fv118)
@@ -38636,9 +38311,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (even? (car lst))
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (even? (car lst)) + -) i 10.0))))
(test (fv118) (float-vector -10.0 -9.0 -8.0 -7.0))
(define (fv119)
@@ -38647,9 +38320,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (eqv? i (car lst))
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (eqv? i (car lst)) + -) i 10.0))))
(test (fv119) (float-vector -10.0 11.0 -8.0 -7.0))
(define (fv120)
@@ -38658,9 +38329,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (= i j)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (= i j) + -) i 10.0))))
(test (fv120) (float-vector -10.0 -9.0 12.0 -7.0))
(define (fv121)
@@ -38669,9 +38338,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (< i j)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (< i j) + -) i 10.0))))
(test (fv121) (float-vector 10.0 11.0 -8.0 -7.0))
(define (fv122)
@@ -38680,9 +38347,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (<= i j)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (<= i j) + -) i 10.0))))
(test (fv122) (float-vector 10.0 11.0 12.0 -7.0))
(define (fv123)
@@ -38691,9 +38356,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (>= i j)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (>= i j) + -) i 10.0))))
(test (fv123) (float-vector -10.0 -9.0 12.0 13.0))
(define (fv124)
@@ -38702,9 +38365,7 @@ EDITS: 1
(i 0 (+ i 1))
(x 0 (+ x 1)))
((= i 4) (and (positive? x) fv))
- (float-vector-set! fv i (if (> i j)
- (+ i 10.0)
- (- i 10.0)))))
+ (float-vector-set! fv i ((if (> i j) + -) i 10.0))))
(test (fv124) (float-vector -10.0 -9.0 -8.0 13.0))
(define (fv125)
@@ -38758,22 +38419,14 @@ EDITS: 1
(j 2))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (float-vector-set! fv i
- (if (or (> i j)
- (= i 3))
- (+ i 10.0)
- (- i 10.0))))))
+ (float-vector-set! fv i ((if (or (> i j) (= i 3)) + -) i 10.0)))))
(test (fv127) (float-vector -10.0 -9.0 -8.0 13.0))
(define (fv128)
(let ((fv (make-float-vector 4)))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (float-vector-set! fv i
- (if (or (= i 1)
- (= i 3))
- (+ i 10.0)
- (- i 10.0))))))
+ (float-vector-set! fv i ((if (or (= i 1) (= i 3)) + -) i 10.0)))))
(test (fv128) (float-vector -10.0 11.0 -8.0 13.0))
(define (fv129)
@@ -38781,11 +38434,7 @@ EDITS: 1
(j 2))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (float-vector-set! fv i
- (if (and (= i j)
- (< i 3))
- (+ i 10.0)
- (- i 10.0))))))
+ (float-vector-set! fv i ((if (and (= i j) (< i 3)) + -) i 10.0)))))
(test (fv129) (float-vector -10.0 -9.0 12.0 -7.0))
(define (fv130)
@@ -38793,10 +38442,7 @@ EDITS: 1
(j #\a))
(do ((i 0 (+ i 1)))
((= i 4) fv)
- (float-vector-set! fv i
- (if (char=? j #\a)
- (+ i 10.0)
- (- i 10.0))))))
+ (float-vector-set! fv i ((if (char=? j #\a) + -) i 10.0)))))
(test (fv130) (float-vector 10.0 11.0 12.0 13.0))
(define (char-permute op . args)
@@ -38955,9 +38601,8 @@ EDITS: 1
(do ((fv (make-float-vector 4))
(i 0 (+ i 1)))
((= i 4) fv)
- (let ((y 1.0))
- ((lambda ()
- (set! (fv i) i))))))
+ ((lambda ()
+ (set! (fv i) i)))))
(test (fv134) (float-vector 0.0 1.0 2.0 3.0))
(define (fv135)
@@ -39235,7 +38880,7 @@ EDITS: 1
(define (fv162)
(let ((fv (make-int-vector 4))
- (iter (make-iterator (list 1 2 3 4))))
+ (iter (make-iterator '(1 2 3 4))))
(do ((i 0 (+ i 1)))
((= i 4) fv)
(int-vector-set! fv i (iterate iter)))))
@@ -39549,8 +39194,7 @@ EDITS: 1
)
(when all-args
- (let ((old-size *clm-file-buffer-size*))
- (set! *clm-file-buffer-size* 100)
+ (let-temporarily ((*clm-file-buffer-size* 100))
(set! *mus-float-equal-fudge-factor* 1e-4)
(define v-1 (make-float-vector 100 .25))
(do ((i 0 (+ i 1)) (x 0.0 (+ x .01))) ((= i 100)) (float-vector-set! v-1 i x))
@@ -39858,15 +39502,15 @@ EDITS: 1
`(" (v10 (tester-10))~%")
`(" (v11 (tester-11))~%")
`(" (v12 (tester-12)))~%")
- `(" (if (or (not (vequal v0 v1)) (not (vequal v1 v2)) (not (vequal v1 v3)) (not (vequal v1 v4)))~%")
+ `(" (if (or (not (mus-arrays-equal? v0 v1)) (not (mus-arrays-equal? v1 v2)) (not (mus-arrays-equal? v1 v3)) (not (mus-arrays-equal? v1 v4)))~%")
`(" (format *stderr* \"~A:~~% no do: ~~A~~% float-vector-set: ~~A~~% outa->v:~~A~~% outa: ~~A~~% list: ~~A~~%\" v0 v1 v2 v3 v4))~%" ,str)
- `(" (if (not (vequal v5 v6))~%")
+ `(" (if (not (mus-arrays-equal? v5 v6))~%")
`(" (format *stderr* \"dox ~A:~~% float-vector-set: ~~A~~% outa->v:~~A~~%\" v5 v6))~%" ,str)
- `(" (if (not (vequal v7 v8))~%")
+ `(" (if (not (mus-arrays-equal? v7 v8))~%")
`(" (format *stderr* \"let ~A:~~% ~~A~~% ~~A~~%\" v7 v8))~%" ,str)
- `(" (if (not (vequal v9 v10))~%")
+ `(" (if (not (mus-arrays-equal? v9 v10))~%")
`(" (format *stderr* \"env let ~A:~~% ~~A~~% ~~A~~%\" v9 v10))~%~%" ,str)
- `(" (if (not (vequal v11 v12))~%")
+ `(" (if (not (mus-arrays-equal? v11 v12))~%")
`(" (format *stderr* \"letx ~A:~~% ~~A~~% ~~A~~%\" v11 v12))))~%~%" ,str)))))))
(define (out-args)
@@ -39955,7 +39599,6 @@ EDITS: 1
args2))
args1))
(out-args)
- (set! *clm-file-buffer-size* old-size)
)))
@@ -40218,21 +39861,18 @@ EDITS: 1
(if (not ind) (snd-display ";with-sound (1): ~A" (map file-name (sounds))))
(let ((mx (maxamp)))
(if (fneq mx .05) (snd-display ";with-sound max (1): ~A" (maxamp))))
- (if (not (and (= (srate ind) 22050)
- (= (mus-sound-srate "test1.snd") 22050)))
+ (if (not (= (srate ind) 22050 (mus-sound-srate "test1.snd")))
(snd-display ";with-sound srate (1): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
(if (not (member (framples ind) '(2205 2206) =))
(snd-display ";with-sound framples (1): ~A" (framples ind)))
- (if (not (and (= (chans ind) 2)
- (= (mus-sound-chans "test1.snd") 2)))
+ (if (not (= (chans ind) 2 (mus-sound-chans "test1.snd")))
(snd-display ";with-sound chans (1): ~A" (chans ind)))
(close-sound ind)
(delete-file "test1.snd"))
(with-sound (:srate 48000 :channels 2 :header-type mus-riff :sample-type mus-lshort :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (not (and (= (srate ind) 48000)
- (= (mus-sound-srate "test1.snd") 48000)))
+ (if (not (= (srate ind) 48000 (mus-sound-srate "test1.snd")))
(snd-display ";with-sound srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
(if (not (= (header-type ind) mus-riff)) (snd-display ";with-sound type (~A, r): ~A" mus-riff (header-type ind)))
(if (not (= (chans ind) 2)) (snd-display ";with-sound chans (2, r): ~A" (chans ind)))
@@ -40241,8 +39881,7 @@ EDITS: 1
(with-sound (:srate 48000 :channels 2 :header-type mus-rf64 :sample-type mus-lshort :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (not (and (= (srate ind) 48000)
- (= (mus-sound-srate "test1.snd") 48000)))
+ (if (not (= (srate ind) 48000 (mus-sound-srate "test1.snd")))
(snd-display ";with-sound srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
(if (not (= (header-type ind) mus-rf64)) (snd-display ";with-sound type (~A, r): ~A" mus-rf64 (header-type ind)))
(if (not (= (chans ind) 2)) (snd-display ";with-sound chans (2, r): ~A" (chans ind)))
@@ -40251,8 +39890,7 @@ EDITS: 1
(with-sound (:srate 48000 :channels 2 :header-type mus-caff :sample-type mus-lshort :output "test1.snd") (fm-violin 0 .1 440 .1))
(let ((ind (find-sound "test1.snd")))
- (if (not (and (= (srate ind) 48000)
- (= (mus-sound-srate "test1.snd") 48000)))
+ (if (not (= (srate ind) 48000 (mus-sound-srate "test1.snd")))
(snd-display ";with-sound mus-caff srate (48000, r): ~A (~A, ~A)" (srate ind) *clm-srate* (mus-sound-srate "test1.snd")))
(if (not (= (header-type ind) mus-caff)) (snd-display ";with-sound type (~A, r): ~A" mus-caff (header-type ind)))
(if (not (= (chans ind) 2)) (snd-display ";with-sound mus-caff chans (2, r): ~A" (chans ind)))
@@ -40294,7 +39932,7 @@ EDITS: 1
(fm-violin 0 .1 440 .1 :degree 45.0))
(let ((ind (find-sound "test1.snd")))
(if (not ind) (snd-display ";with-sound (2): ~A" (map file-name (sounds)))
- (if (> (- (framples ind) 24255) 1) (snd-display ";with-sound reverbed framples (2): ~A" (framples ind))))
+ (if (> (framples ind) 24256) (snd-display ";with-sound reverbed framples (2): ~A" (framples ind))))
(close-sound ind))
(with-sound (:srate 22050 :comment "Snd+Run!" :scaled-to .5) (fm-violin 0 .1 440 .1))
@@ -40351,9 +39989,9 @@ EDITS: 1
(scan-channel (lambda (y)
(set! i (+ i 1))
(and (< i 100)
- (fneq y (sin (* 2 pi i (/ 1000.0 44100.0))))
+ (fneq y (sin (/ (* 2 pi i 1000.0) 44100.0)))
(begin
- (format () "~%;with-sound sine: ~D ~A ~A" i y (sin (* 2 pi i (/ 1000.0 44100.0))))
+ (format () "~%;with-sound sine: ~D ~A ~A" i y (sin (/ (* 2 pi i 1000.0) 44100.0)))
#t)))))
(close-sound ind))
@@ -40375,15 +40013,6 @@ EDITS: 1
(snd-display ";with-sound make-oscil maxamp: ~A" (maxamp ind)))
(close-sound ind))
- (let ((old-srate *clm-srate*))
- (with-sound ()
- (if (not (= old-srate *clm-srate*))
- (format () ";srates: ~A ~A~%" old-srate, *clm-srate*))
- (with-sound (:srate 12345)
- (if (not (= *clm-srate* 12345))
- (format () ";clm-srate: ~A (12345)~%" *clm-srate*)))
- (if (not (= old-srate *clm-srate*))
- (format () ";returned srates: ~A ~A~%" old-srate, *clm-srate*))))
(for-each close-sound (sounds))
(if (file-exists? "ii.scm")
@@ -40807,7 +40436,7 @@ EDITS: 1
(mus-file-mix *output* temp-2 22050)))
(let ((ind (find-sound "test.snd")))
(if (not (sound? ind)) (snd-display ";with-sound+sound-lets init: no test.snd?"))
- (if (or (> (maxamp ind) .2) (< (maxamp ind) .15)) (snd-display ";with-mix+sound-lets maxamp: ~A" (maxamp ind)))
+ (if (not (>= 0.2 (maxamp ind) 0.15)) (snd-display ";with-mix+sound-lets maxamp: ~A" (maxamp ind)))
(if (fneq 3.0 (/ (framples ind) (srate ind))) (snd-display ";with-sound+sound-lets dur: ~A" (/ (framples ind) (srate ind))))
(close-sound ind))
@@ -40928,27 +40557,27 @@ EDITS: 1
(let ((o2 (optkey-1)))
(if o2 (snd-display ";optkey-1 2: ~A" o2)))
(let ((o2 (optkey-2 1 2)))
- (if (not (equal? o2 (list 1 2))) (snd-display ";optkey-2: ~A" o2)))
+ (if (not (equal? o2 '(1 2))) (snd-display ";optkey-2: ~A" o2)))
(let ((o2 (optkey-2 :a 1 :b 2)))
- (if (not (equal? o2 (list 1 2))) (snd-display ";optkey-2 1: ~A" o2)))
+ (if (not (equal? o2 '(1 2))) (snd-display ";optkey-2 1: ~A" o2)))
(let ((o2 (optkey-2)))
- (if (not (equal? o2 (list 3 #f))) (snd-display ";optkey-2 2: ~A" o2)))
+ (if (not (equal? o2 '(3 #f))) (snd-display ";optkey-2 2: ~A" o2)))
(let ((o2 (optkey-2 1 :b 2)))
- (if (not (equal? o2 (list 1 2))) (snd-display ";optkey-2 3: ~A" o2)))
+ (if (not (equal? o2 '(1 2))) (snd-display ";optkey-2 3: ~A" o2)))
(let ((o2 (optkey-3 1 2 3)))
- (if (not (equal? o2 (list 1 2 3))) (snd-display ";optkey-3: ~A" o2)))
+ (if (not (equal? o2 '(1 2 3))) (snd-display ";optkey-3: ~A" o2)))
(let ((o2 (optkey-3 1 :b 2 :c 3)))
- (if (not (equal? o2 (list 1 2 3))) (snd-display ";optkey-3 1: ~A" o2)))
+ (if (not (equal? o2 '(1 2 3))) (snd-display ";optkey-3 1: ~A" o2)))
(let ((o2 (optkey-3 1 2 :c 3)))
- (if (not (equal? o2 (list 1 2 3))) (snd-display ";optkey-3 2: ~A" o2)))
+ (if (not (equal? o2 '(1 2 3))) (snd-display ";optkey-3 2: ~A" o2)))
(let ((o2 (optkey-4)))
- (if (not (equal? o2 (list 1 2 3 #f))) (snd-display ";optkey-4: ~A" o2)))
+ (if (not (equal? o2 '(1 2 3 #f))) (snd-display ";optkey-4: ~A" o2)))
(let ((o2 (optkey-4 1 :b 3 :c 4 :d 5)))
- (if (not (equal? o2 (list 1 3 4 5))) (snd-display ";optkey-4 1: ~A 1" o2)))
+ (if (not (equal? o2 '(1 3 4 5))) (snd-display ";optkey-4 1: ~A 1" o2)))
(let ((o2 (optkey-4 1 :d 5 :c 4 :b 3)))
- (if (not (equal? o2 (list 1 3 4 5))) (snd-display ";optkey-4 2: ~A 1" o2)))
+ (if (not (equal? o2 '(1 3 4 5))) (snd-display ";optkey-4 2: ~A 1" o2)))
(let ((o2 (optkey-4 1 3 4 5)))
- (if (not (equal? o2 (list 1 3 4 5))) (snd-display ";optkey-4 3: ~A 2" o2)))
+ (if (not (equal? o2 '(1 3 4 5))) (snd-display ";optkey-4 3: ~A 2" o2)))
(when (and (or (provided? 'snd-motif)
(and (provided? 'snd-gtk) (defined? 'gtk_box_new)))
@@ -40981,12 +40610,11 @@ EDITS: 1
(if (pair? *clm-reverb-data*) (snd-display ";*clm-reverb-data*: ~A?" *clm-reverb-data*))
(if *clm-delete-reverb* (snd-display ";*clm-delete-reverb*: ~A" *clm-delete-reverb*))
- (let ((old-stats *clm-statistics*))
+ (let-temporarily ((*clm-statistics* #t))
(set! *clm-channels* 2)
(set! *clm-srate* 44100)
(set! *clm-file-name* "test.wav")
(set! *clm-verbose* #t)
- (set! *clm-statistics* #t)
(set! *clm-play* #t)
(set! *clm-sample-type* mus-mulaw)
(set! *clm-header-type* mus-riff)
@@ -41008,22 +40636,19 @@ EDITS: 1
(if (file-exists? "test.rev") (snd-display ";perhaps reverb not deleted in ws?"))
(close-sound ind))))
- (let ((val 0)
- (old-hook *clm-notehook*))
- (set! *clm-notehook* (lambda args (set! val 1)))
- (with-sound () (fm-violin 0 .1 440 .1))
- (if (not (= val 1)) (snd-display ";*clm-notehook*: ~A ~A" val *clm-notehook*))
- (with-sound (:notehook (lambda args (set! val 2))) (fm-violin 0 .1 440 .1))
- (if (not (= val 2)) (snd-display ";:notehook: ~A" val))
- (with-sound () (fm-violin 0 .1 440 .1))
- (if (not (= val 1)) (snd-display ";*clm-notehook* (1): ~A ~A" val *clm-notehook*))
- (set! *clm-notehook* old-hook))
+ (let ((val 0))
+ (let-temporarily ((*clm-notehook* (lambda args (set! val 1))))
+ (with-sound () (fm-violin 0 .1 440 .1))
+ (if (not (= val 1)) (snd-display ";*clm-notehook*: ~A ~A" val *clm-notehook*))
+ (with-sound (:notehook (lambda args (set! val 2))) (fm-violin 0 .1 440 .1))
+ (if (not (= val 2)) (snd-display ";:notehook: ~A" val))
+ (with-sound () (fm-violin 0 .1 440 .1))
+ (if (not (= val 1)) (snd-display ";*clm-notehook* (1): ~A ~A" val *clm-notehook*))))
(set! *clm-channels* 1)
(set! *clm-srate* 22050)
(set! *clm-file-name* "test.snd")
(set! *clm-verbose* #f)
- (set! *clm-statistics* old-stats)
(set! *clm-play* #f)
(set! *clm-sample-type* mus-ldouble)
(set! *clm-header-type* mus-next)
@@ -41058,10 +40683,8 @@ EDITS: 1
(clm-reverb-sound .1 jc-reverb)
(close-sound ind)))
- (let ((old-play *clm-play*))
- (set! *clm-play* #f)
- (make-birds)
- (set! *clm-play* old-play))
+ (let-temporarily ((*clm-play* #f))
+ (make-birds))
(for-each close-sound (sounds))
@@ -41195,12 +40818,9 @@ EDITS: 1
(if (fneq mx .1) (snd-display ";scaled-to ~A" mx))
(close-sound ind)
- (let ((old-bufsize *clm-file-buffer-size*)
- (old-tsize *clm-table-size*)
- (old-arrp *clm-array-print-length*))
- (set! *clm-file-buffer-size* 1048576)
- (set! *clm-table-size* 256)
- (set! *clm-array-print-length* 123)
+ (let-temporarily ((*clm-file-buffer-size* 1048576)
+ (*clm-table-size* 256)
+ (*clm-array-print-length* 123))
(let ((tsize 0)
(arrp 0))
(set! file (with-sound (:sample-type mus-lfloat :header-type mus-next)
@@ -41212,9 +40832,6 @@ EDITS: 1
(if (not (= mx 1048576)) (snd-display ";*clm-file-buffer-size*: ~A" mx))
(if (not (= tsize 256)) (snd-display ";*clm-table-size*: ~A" tsize))
(if (not (= arrp 123)) (snd-display ";*clm-array-print-length*: ~A" arrp))
- (set! *clm-file-buffer-size* old-bufsize)
- (set! *clm-table-size* old-tsize)
- (set! *clm-array-print-length* old-arrp)
(close-sound ind)))
(set! file (with-sound () (fm-violin 0 3.0 440 .1)))
@@ -41285,7 +40902,26 @@ EDITS: 1
(let ((file (new-sound "tmp.snd" 4 22050 mus-ldouble mus-next)))
(mix-move-sound 0 "oboe.snd" (make-spiral-path :turns 3))
(close-sound file))
-
+
+ (let ((path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
+ (if (not (equal? path '(open-bezier-path () () () () () () () () () ((-10 10) (0.5 0.5) (10 10)) #f #f () () () () () () () 0.01 #f #f #f)))
+ (snd-display "dlocsig path 1: ~A~%" path)))
+ (let ((path (make-path :path '((-10 10 0 1) (0 5 0 0) (10 10 10 1)) :3d #t)))
+ (if (not (equal? path '(open-bezier-path () () () () () () () () () ((-10 10 0 1) (0 5 0 0) (10 10 10 1)) #t #f () () () () () () () 0.01 #f #f #f)))
+ (snd-display "dlocsig path 2: ~A~%" path)))
+ (let ((path (make-spiral-path :total-angle 360)))
+ (if (not (equal? path '(spiral-path () () () () () () () () () () #f #f 0.0 360 18/5 () (0 10 1 10) (0 0 1 0) (0 1 1 1))))
+ (snd-display "dlocsig path 3: ~A~%" path)))
+ (let ((path (make-spiral-path :turns 3)))
+ (if (not (equal? path '(spiral-path () () () () () () () () () () #f #f 0.0 #f 18/5 3 (0 10 1 10) (0 0 1 0) (0 1 1 1))))
+ (snd-display "dlocsig path 4: ~A~%" path)))
+ (let ((path (make-literal-path '((-10 10) (10 10)) :polar #t)))
+ (if (not (equal? path '(literal-path () () () () () () () () () ((-10 10) (10 10)) #f #t)))
+ (snd-display "dlocsig path 5: ~A~%" path)))
+ (let ((path (make-spiral-path :total-angle 360 :distance '(0 10 1 30 2 10))))
+ (if (not (equal? path '(spiral-path () () () () () () () () () () #f #f 0.0 360 18/5 () (0 10 1 30 2 10) (0 0 1 0) (0 1 1 1))))
+ (snd-display "dlocsig path 6: ~A~%" path)))
+
(with-sound (:channels 2) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
(with-sound (:channels 4) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
(with-sound (:channels 8) (dloc-sinewave 0 1.0 440 .5 :path (make-path '((-10 10) (0.5 0.5) (10 10)) :3d #f)))
@@ -41326,11 +40962,11 @@ EDITS: 1
(do ((i 0 (+ i 1)))
((= i c) v)
(set! (v i) (sample n ind i)))))
- (if (not (vvequal (frample 2438) (make-float-vector 5)))
+ (if (not (vmus-arrays-equal? (frample 2438) (make-float-vector 5)))
(snd-display ";freeverb 2438: ~A" (frample 2438)))
- (if (not (vvequal (frample 2439) (float-vector 0.04276562482118607 -0.0009843750158324838 0.00995312537997961 -0.0009843750158324838 0.001750000054016709)))
+ (if (not (vmus-arrays-equal? (frample 2439) (float-vector 0.04276562482118607 -0.0009843750158324838 0.00995312537997961 -0.0009843750158324838 0.001750000054016709)))
(format *stderr* ";freeverb 2439: ~A" (frample 2439)))
- (if (not (vvequal (frample 4305) (float-vector 0.03010422177612782 -0.00203015236184001 0.007028832100331783 -0.001004761666990817 0.00125998433213681)))
+ (if (not (vmus-arrays-equal? (frample 4305) (float-vector 0.03010422177612782 -0.00203015236184001 0.007028832100331783 -0.001004761666990817 0.00125998433213681)))
(format *stderr* ";freeverb 4305: ~A" (frample 4305)))
(close-sound))
@@ -41395,37 +41031,37 @@ EDITS: 1
(if (fneq (float-vector-peak v1) .1) (snd-display ";with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 2210)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (float-vector-peak v2) .1) (snd-display ";with-sound -> float-vector fm-violin maxamp: ~A" (float-vector-peak v2)))
- (if (not (vequal v1 v2)) (snd-display ";with-sound -> float-vector v1 v2 not equal?")))
+ (if (not (mus-arrays-equal? v1 v2)) (snd-display ";with-sound -> float-vector v1 v2 not equal?")))
(sound-let ((tmp () (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)))
(let ((v3 (make-float-vector 2210)))
(file->array tmp 0 0 2205 v3)
- (if (not (vequal v1 v3)) (snd-display ";with-sound -> float-vector v1 v3 not equal?"))))
+ (if (not (mus-arrays-equal? v1 v3)) (snd-display ";with-sound -> float-vector v1 v3 not equal?"))))
(with-sound (v1)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
(if (fneq (float-vector-peak v1) .2) (snd-display ";with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1))))
- (let ((v1 (with-sound ((make-float-vector (list 1 2210) 0.0)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (let ((v1 (with-sound ((make-float-vector '(1 2210))) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (maxamp v1) .1) (snd-display ";with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 1 2210) 0.0)) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (let ((v2 (with-sound ((make-float-vector '(1 2210))) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (maxamp v2) .1) (snd-display ";with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
- (if (not (sd-equal v1 v2)) (snd-display ";with-sound -> vector2 v1 v2 not equal?")))
+ (if (not (mus-arrays-equal? v1 v2)) (snd-display ";with-sound -> vector2 v1 v2 not equal?")))
(with-sound (v1)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
(if (fneq (maxamp v1) .2) (snd-display ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1))))
(set! (locsig-type) mus-interp-linear)
- (let ((v1 (with-sound ((make-float-vector (list 2 2210) 0.0))
+ (let ((v1 (with-sound ((make-float-vector '(2 2210)))
(if (not (= (mus-channels *output*) 2)) (snd-display ";with-sound *output* chans: ~A" (mus-channels *output*)))
(fm-violin 0 .1 440 .1 :degree 45 :random-vibrato-amplitude 0.0))))
- (if (fneq (maxamp v1) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
- (if (fneq (maxamp v1) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 2 2210) 0.0))
+ (when (fneq (maxamp v1) .05)
+ (snd-display ";with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
+ (let ((v2 (with-sound ((make-float-vector '(2 2210)))
(fm-violin 0 .1 440 .1 :degree 45 :random-vibrato-amplitude 0.0))))
- (if (fneq (maxamp v2) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
- (if (fneq (maxamp v2) .05) (snd-display ";with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
- (if (not (sd-equal v1 v2)) (snd-display ";with-sound (2 chans) -> vector2 v1 v2 not equal?")))
+ (when (fneq (maxamp v2) .05)
+ (snd-display ";with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
+ (if (not (mus-arrays-equal? v1 v2)) (snd-display ";with-sound (2 chans) -> vector2 v1 v2 not equal?")))
(with-sound (v1)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0))
@@ -41437,19 +41073,19 @@ EDITS: 1
(let ((v2 (with-sound ((make-float-vector 2210) :scaled-to .3) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (float-vector-peak v2) .3)
(snd-display ";with-sound -> float-vector fm-violin maxamp scaled-to: ~A" (float-vector-peak v2)))
- (if (not (vequal v1 v2)) (snd-display ";with-sound (scaled-to) -> float-vector v1 v2 not equal?")))
+ (if (not (mus-arrays-equal? v1 v2)) (snd-display ";with-sound (scaled-to) -> float-vector v1 v2 not equal?")))
(with-sound (v1 :scaled-by 2.0)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
(if (fneq (float-vector-peak v1) .4) (snd-display ";with-sound -> float-vector fm-violin maxamp (opt 2 scaled-by): ~A" (float-vector-peak v1))))
- (let ((v1 (with-sound ((make-float-vector (list 1 2210) 0.0) :scaled-to .5) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (let ((v1 (with-sound ((make-float-vector '(1 2210)) :scaled-to .5) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (maxamp v1) .5)
(snd-display ";with-sound -> vector2 fm-violin maxamp (opt, scaled-to): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 1 2210) 0.0) :scaled-to .5) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
+ (let ((v2 (with-sound ((make-float-vector '(1 2210)) :scaled-to .5) (fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
(if (fneq (maxamp v2) .5)
(snd-display ";with-sound -> vector2 fm-violin maxamp scaled-to: ~A" (maxamp v2)))
- (if (not (sd-equal v1 v2)) (snd-display ";with-sound scaled-to -> vector2 v1 v2 not equal?")))
+ (if (not (mus-arrays-equal? v1 v2)) (snd-display ";with-sound scaled-to -> vector2 v1 v2 not equal?")))
(with-sound (v1 :scaled-by 0.5)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
@@ -41468,7 +41104,7 @@ EDITS: 1
"\n;vector:\n maxamp: 0.1000\n compute time: 0.180\n")
string=?))
(snd-display ";with-sound to float-vector stats: [~A]" stats-string))
- (with-sound ((make-float-vector (list 1 2210) 0.0) :scaled-to .5 :statistics (lambda (str) (set! stats-string str)))
+ (with-sound ((make-float-vector '(1 2210)) :scaled-to .5 :statistics (lambda (str) (set! stats-string str)))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
(if (not (member stats-string '("\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.000\n"
"\n;vector:\n maxamp (before scaling): 0.1000\n compute time: 0.001\n"
@@ -41480,7 +41116,7 @@ EDITS: 1
string=?))
(snd-display ";with-sound to float-vector stats: [~A]" stats-string))
- (with-sound ((make-float-vector (list 4 2210) 0.0) :channels 4 :statistics (lambda (str) (set! stats-string str)))
+ (with-sound ((make-float-vector '(4 2210)) :channels 4 :statistics (lambda (str) (set! stats-string str)))
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .2 :degree 90 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
@@ -41499,7 +41135,7 @@ EDITS: 1
(fm-violin 0 .1 440 .1 :degree 45 :random-vibrato-amplitude 0.0))))
(if (fneq (v1 0) 0.0) (snd-display ";overwrite float-vector with-sound (4): ~A (~A)" (v1 0) (float-vector-peak v1))))
- (let ((v1 (with-sound ((make-float-vector (list 4 20) 0.0) :channels 4)
+ (let ((v1 (with-sound ((make-float-vector '(4 20)) :channels 4)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .2 :degree 90 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
@@ -41507,7 +41143,7 @@ EDITS: 1
(do ((i 0 (+ i 1))) ((= i 4))
(if (fneq (v1 i 0) 0.0) (snd-display ";overwrite sd ~D with-sound: ~A" i (v1 i 0)))))
- (let ((v1 (with-sound ((make-float-vector (list 2 20) 0.0) 4)
+ (let ((v1 (with-sound ((make-float-vector '(2 20)) 4)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .2 :degree 90 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
@@ -41515,7 +41151,7 @@ EDITS: 1
(do ((i 0 (+ i 1))) ((= i 2))
(if (fneq (v1 i 0) 0.0) (snd-display ";overwrite sd (2) ~D with-sound: ~A" i (v1 i 0)))))
- (let ((v1 (with-sound ((make-float-vector (list 4 20) 0.0) :channels 1)
+ (let ((v1 (with-sound ((make-float-vector '(4 20)) :channels 1)
(fm-violin 0 .1 440 .1 :degree 0 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .2 :degree 90 :random-vibrato-amplitude 0.0)
(fm-violin 0 .1 440 .3 :degree 180 :random-vibrato-amplitude 0.0)
@@ -41523,7 +41159,7 @@ EDITS: 1
(do ((i 0 (+ i 1))) ((= i 4))
(if (fneq (v1 i 0) 0.0) (snd-display ";overwrite sd (4) ~D with-sound: ~A" i (v1 i 0)))))
)
- (list 0 3 6))
+ '(0 3 6))
;; reverb cases parallel to above
(let ((v1 (with-sound ((make-float-vector 44100) :reverb jc-reverb)
@@ -41531,7 +41167,7 @@ EDITS: 1
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0 :reverb-amount 0.9))))
(let ((v4 (with-sound ((make-float-vector 44100))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (vequal v1 v4) (snd-display ";reverb output not written to float-vector?")))
+ (if (mus-arrays-equal? v1 v4) (snd-display ";reverb output not written to float-vector?")))
(if (< (float-vector-peak v1) .28)
(snd-display ";rev with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 44100) :reverb jc-reverb) (fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
@@ -41543,15 +41179,15 @@ EDITS: 1
(if (< (float-vector-peak v1) .28)
(snd-display ";rev with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1))))
- (let ((v1 (with-sound ((make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (let ((v1 (with-sound ((make-float-vector '(1 44100)) :reverb jc-reverb)
(if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length sd: ~A" (mus-length *output*)))
(fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0))))
- (let ((v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
+ (let ((v4 (with-sound ((make-float-vector '(1 44100)))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (sd-equal v1 v4) (snd-display ";reverb output not written to sd?")))
+ (if (mus-arrays-equal? v1 v4) (snd-display ";reverb output not written to sd?")))
(if (< (maxamp v1) .23)
(snd-display ";rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 1 44100) 0.0) :reverb jc-reverb) (fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
+ (let ((v2 (with-sound ((make-float-vector '(1 44100)) :reverb jc-reverb) (fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (maxamp v2) .23)
(snd-display ";rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2))))
(with-sound (v1 :reverb jc-reverb)
@@ -41561,21 +41197,19 @@ EDITS: 1
(snd-display ";with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1))))
(set! (locsig-type) mus-interp-linear)
- (let ((v1 (with-sound ((make-float-vector (list 2 44100) 0.0) :reverb jc-reverb)
+ (let ((v1 (with-sound ((make-float-vector '(2 44100)) :reverb jc-reverb)
(if (not (= (mus-channels *output*) 2))
(snd-display ";rev with-sound *output* chans: ~A" (mus-channels *output*)))
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
- (if (< (maxamp v1) .23)
- (snd-display ";rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
- (if (< (maxamp v1) .23)
- (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
+ (when (< (maxamp v1) .23)
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 2 44100) 0.0) :reverb jc-reverb)
+ (let ((v2 (with-sound ((make-float-vector '(2 44100)) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
- (if (< (maxamp v2) .23)
- (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
- (if (< (maxamp v2) .23)
- (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2))))
+ (when (< (maxamp v2) .23)
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2))
+ (snd-display ";rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2))))
(with-sound (v1 :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9)
(fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9))
@@ -41588,7 +41222,7 @@ EDITS: 1
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0 :reverb-amount 0.9))))
(let ((v4 (with-sound ((make-float-vector 44100))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (vequal v1 v4) (snd-display ";1 reverb output not written to float-vector?")))
+ (if (mus-arrays-equal? v1 v4) (snd-display ";1 reverb output not written to float-vector?")))
(if (< (float-vector-peak v1) .28)
(snd-display ";1 rev with-sound -> float-vector fm-violin maxamp (opt): ~A" (float-vector-peak v1)))
(let ((v2 (with-sound ((make-float-vector 44100) :revfile (make-float-vector 44100) :reverb jc-reverb)
@@ -41601,15 +41235,15 @@ EDITS: 1
(if (< (float-vector-peak v1) .28)
(snd-display ";1 rev with-sound -> float-vector fm-violin maxamp (opt 2): ~A" (float-vector-peak v1)))))
- (let ((v1 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (let ((v1 (with-sound ((make-float-vector '(1 44100)) :revfile (make-float-vector '(1 44100)) :reverb jc-reverb)
(if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length sd: ~A" (mus-length *output*)))
(fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0))))
- (let ((v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
+ (let ((v4 (with-sound ((make-float-vector '(1 44100)))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (sd-equal v1 v4) (snd-display ";2 reverb output not written to sd?")))
+ (if (mus-arrays-equal? v1 v4) (snd-display ";2 reverb output not written to sd?")))
(if (< (maxamp v1) .28)
(snd-display ";2 rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (let ((v2 (with-sound ((make-float-vector '(1 44100)) :revfile (make-float-vector '(1 44100)) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (maxamp v2) .28)
(snd-display ";2 rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
@@ -41619,15 +41253,15 @@ EDITS: 1
(if (< (maxamp v1) .5)
(snd-display ";2 with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
- (let ((v1 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (let ((v1 (with-sound ((make-float-vector '(1 44100)) :revfile (make-float-vector '(1 44100)) :reverb jc-reverb)
(if (not (= (mus-length *output*) 44100)) (snd-display ";ws mus-length sd: ~A" (mus-length *output*)))
(fm-violin 0 .1 440 .1 :reverb-amount 0.9 :random-vibrato-amplitude 0.0))))
- (let ((v4 (with-sound ((make-float-vector (list 1 44100) 0.0))
+ (let ((v4 (with-sound ((make-float-vector '(1 44100)))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))))
- (if (sd-equal v1 v4) (snd-display ";2 reverb output not written to sd?")))
+ (if (mus-arrays-equal? v1 v4) (snd-display ";2 reverb output not written to sd?")))
(if (< (maxamp v1) .28)
(snd-display ";2 rev with-sound -> vector2 fm-violin maxamp (opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 1 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (let ((v2 (with-sound ((make-float-vector '(1 44100)) :revfile (make-float-vector '(1 44100)) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :reverb-amount 0.9))))
(if (< (maxamp v2) .28)
(snd-display ";2 rev with-sound -> vector2 fm-violin maxamp: ~A" (maxamp v2)))
@@ -41638,20 +41272,18 @@ EDITS: 1
(snd-display ";2 with-sound -> vector2 fm-violin maxamp (opt 2): ~A" (maxamp v1)))))
(set! (locsig-type) mus-interp-linear)
- (let ((v1 (with-sound ((make-float-vector (list 2 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (let ((v1 (with-sound ((make-float-vector '(2 44100)) :revfile (make-float-vector '(1 44100)) :reverb jc-reverb)
(if (not (= (mus-channels *output*) 2))
(snd-display ";3 rev with-sound *output* chans: ~A" (mus-channels *output*)))
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
- (if (< (maxamp v1) .23)
- (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1)))
- (if (< (maxamp v1) .23)
- (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
- (let ((v2 (with-sound ((make-float-vector (list 2 44100) 0.0) :revfile (make-float-vector (list 1 44100) 0.0) :reverb jc-reverb)
+ (when (< (maxamp v1) .23)
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (1 opt): ~A" (maxamp v1))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2 opt): ~A" (maxamp v1)))
+ (let ((v2 (with-sound ((make-float-vector '(2 44100)) :revfile (make-float-vector '(1 44100)) :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 45 :reverb-amount 0.9))))
- (if (< (maxamp v2) .23)
- (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2)))
- (if (< (maxamp v2) .23)
- (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
+ (when (< (maxamp v2) .23)
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2): ~A" (maxamp v2))
+ (snd-display ";3 rev with-sound -> vector2 fm-violin maxamp (2 2): ~A" (maxamp v2)))
(with-sound (v1 :revfile v2 :reverb jc-reverb)
(fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9)
(fm-violin 0 .1 440 .1 :degree 0 :reverb-amount 0.9))
@@ -41676,23 +41308,23 @@ EDITS: 1
(simple-outn 0 .01 440 0.5 0.0 0.0 0.0 0.0 0.0)
(simple-outn 0 .01 440 0.2 0.0 0.0 0.0 0.0 0.0))))
(if (fneq (float-vector-peak v6) 0.7) (snd-display ";outa tests 11 ~A: ~A" n (float-vector-peak v6))))
- (let* ((sd1 (with-sound ((make-float-vector (list 1 4410) 0.0))
+ (let* ((sd1 (with-sound ((make-float-vector '(1 4410)))
(simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
(mx1 (maxamp sd1)))
(if (fneq mx1 .1) (snd-display ";outa tests 6 ~A: ~A" n mx1)))
- (let* ((sd3 (with-sound ((make-float-vector (list 2 4410) 0.0))
+ (let* ((sd3 (with-sound ((make-float-vector '(2 4410)))
(simple-outn 0 .01 440 0.0 0.0 .3 .4 0.0 0.0)))
(mx3 (maxamp sd3)))
(if (fneq mx3 0.0) (snd-display ";outa tests 8 ~A: ~A" n mx3)))
- (let* ((sd4 (with-sound ((make-float-vector (list 4 4410) 0.0) :reverb simple-in-rev :reverb-channels 2 :reverb-data '(0.0 1.0 1.0 1.0))
+ (let* ((sd4 (with-sound ((make-float-vector '(4 4410)) :reverb simple-in-rev :reverb-channels 2 :reverb-data '(0.0 1.0 1.0 1.0))
(simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.25)))
(mx4 (maxamp sd4)))
(if (fneq mx4 0.5) (snd-display ";outa tests 9 ~A: ~A" n mx4)))
- (let* ((sd5 (with-sound ((make-float-vector (list 4 4410) 0.0) :reverb simple-in-rev :reverb-channels 1 :reverb-data '(0.0 1.0 1.0 1.0))
+ (let* ((sd5 (with-sound ((make-float-vector '(4 4410)) :reverb simple-in-rev :reverb-channels 1 :reverb-data '(0.0 1.0 1.0 1.0))
(simple-outn 0 .01 440 0.0 0.0 0.0 0.0 0.5 0.25)))
(mx5 (maxamp sd5)))
(if (fneq mx5 0.5) (snd-display ";outa tests 10 ~A: ~A" n mx5)))
- (let* ((sd6 (with-sound ((make-float-vector (list 4 4410) 0.0))
+ (let* ((sd6 (with-sound ((make-float-vector '(4 4410)))
(simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)
(simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0)))
(mx6 (maxamp sd6)))
@@ -41703,7 +41335,7 @@ EDITS: 1
(with-sound (v1 :continue-old-file #t)
(simple-outn 0 .1 440 .1 .2 .3 .4 0.0 0.0))
(if (fneq (float-vector-peak v1) 0.2) (snd-display ";outa tests 13 ~A: ~A" n (float-vector-peak v1)))
- (let ((sd2 (with-sound ((make-float-vector (list 4 4410) 0.0))
+ (let ((sd2 (with-sound ((make-float-vector '(4 4410)))
(simple-outn 0 .01 440 .1 .2 .3 .4 0.0 0.0))))
(let ((mx2 (maxamp sd2)))
(if (fneq mx2 .4) (snd-display ";outa tests 7 ~A: ~A" n mx2)))
@@ -41711,13 +41343,13 @@ EDITS: 1
(simple-outn 0 .1 440 .1 .2 .3 .4 0.0 0.0))
(let ((mx7 (maxamp sd2)))
(if (fneq mx7 .8) (snd-display ";outa tests 14 ~A: ~A" n mx7))))))
- (list 0 6))
+ '(0 6))
(let* ((file (with-sound ()
(fm-violin 0 .1 880 .1 :random-vibrato-amplitude 0.0)
(let ((v1 (with-temp-sound (:output (make-float-vector 2210))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0)))
- (sd1 (with-temp-sound (:output (make-float-vector (list 1 2210) 0.0))
+ (sd1 (with-temp-sound (:output (make-float-vector '(1 2210)))
(fm-violin 0 .1 660 .1 :random-vibrato-amplitude 0.0))))
(do ((i 0 (+ i 1)))
((= i 2205))
@@ -41728,7 +41360,7 @@ EDITS: 1
(snd-display ";can't find mixed with-sound output")
(let ((mx (maxamp ind 0)))
(if (< mx .35) (snd-display ";mixed with-sound max: ~A" mx))
- (if (not (vequal (channel->float-vector 1000 10) (float-vector 0.255 0.275 0.316 0.364 0.391 0.379 0.337 0.283 0.228 0.170)))
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 10) (float-vector 0.255 0.275 0.316 0.364 0.391 0.379 0.337 0.283 0.228 0.170)))
(snd-display ";mixed with-sound: ~A" (channel->float-vector 1000 10)))
(close-sound ind))))
@@ -41736,7 +41368,7 @@ EDITS: 1
(fm-violin 0 .1 880 .1 :random-vibrato-amplitude 0.0)
(sound-let ((v1 (:output (make-float-vector 2210))
(fm-violin 0 .1 440 .1 :random-vibrato-amplitude 0.0))
- (sd1 (:output (make-float-vector (list 1 2210) 0.0))
+ (sd1 (:output (make-float-vector '(1 2210)))
(fm-violin 0 .1 660 .1 :random-vibrato-amplitude 0.0))
(fs1 ()
(fm-violin 0 .1 110 .1 :random-vibrato-amplitude 0.0)))
@@ -41750,7 +41382,7 @@ EDITS: 1
(snd-display ";can't find mixed with-sound sound-let output")
(let ((mx (maxamp ind 0)))
(if (< mx .375) (snd-display ";mixed with-sound max: ~A" mx))
- (if (not (vequal (channel->float-vector 1000 10) (float-vector 0.349 0.370 0.412 0.461 0.489 0.478 0.436 0.383 0.328 0.270)))
+ (if (not (mus-arrays-equal? (channel->float-vector 1000 10) (float-vector 0.349 0.370 0.412 0.461 0.489 0.478 0.436 0.383 0.328 0.270)))
(snd-display ";mixed with-sound via sound-let: ~A" (channel->float-vector 1000 10)))
(close-sound ind))))
@@ -41760,7 +41392,7 @@ EDITS: 1
(if (not (sound? snd)) (snd-display ";with-mixed-sound (1): ~A?" res))
(let ((mxs (mixes snd 0))
(info (sound-property 'with-mixed-sound-info snd)))
- (if (not (list? mxs))
+ (if (not (pair? mxs))
(snd-display ";with-mixed-sound (1) mixes: ~A" mxs))
(if (not (and (equal? (car (info 0)) (car mxs))
(= (cadr (info 0)) 0)
@@ -41777,7 +41409,7 @@ EDITS: 1
(if (not (sound? snd)) (snd-display ";with-mixed-sound (2): ~A?" res))
(let ((mxs (mixes snd 0))
(info (sound-property 'with-mixed-sound-info snd)))
- (if (not (and (list? mxs)
+ (if (not (and (pair? mxs)
(= (length mxs) 2)))
(snd-display ";with-mixed-sound mixes (2): ~A" mxs))
(if (not (and (equal? (car (info 0)) (car mxs))
@@ -42585,7 +42217,7 @@ EDITS: 1
(outa i (green-noise gen))))))
(snd (find-sound res)))
(if (not (sound? snd)) (snd-display ";green-noise ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 1.0)) (snd-display ";green-noise max: ~A" (maxamp snd))))
+ (if (not (<= 0.01 (maxamp snd) 1.0)) (snd-display ";green-noise max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise 100.0 0.1 -0.1 0.5)))
@@ -42594,7 +42226,7 @@ EDITS: 1
(outa i (green-noise gen))))))
(snd (find-sound res)))
(if (not (sound? snd)) (snd-display ";green-noise .5 ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 0.5)) (snd-display ";green-noise .5 max: ~A" (maxamp snd))))
+ (if (not (<= 0.01 (maxamp snd) 0.5)) (snd-display ";green-noise .5 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise-interp 100.0)))
@@ -42603,7 +42235,7 @@ EDITS: 1
(outa i (green-noise-interp gen))))))
(snd (find-sound res)))
(if (not (sound? snd)) (snd-display ";green-noise-interp ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 1.0)) (snd-display ";green-noise-interp max: ~A" (maxamp snd))))
+ (if (not (<= 0.01 (maxamp snd) 1.0)) (snd-display ";green-noise-interp max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-green-noise-interp 100.0 0.1 -0.1 0.5)))
@@ -42612,7 +42244,7 @@ EDITS: 1
(outa i (green-noise-interp gen))))))
(snd (find-sound res)))
(if (not (sound? snd)) (snd-display ";green-noise-interp .5 ~A" snd))
- (if (or (< (maxamp snd) 0.01) (> (maxamp snd) 0.5)) (snd-display ";green-noise-interp .5 max: ~A" (maxamp snd))))
+ (if (not (<= 0.01 (maxamp snd) 0.5)) (snd-display ";green-noise-interp .5 max: ~A" (maxamp snd))))
(let* ((res (with-sound (:clipped #f)
(let ((gen (make-tanhsin 440.0 2.0)))
@@ -42625,8 +42257,7 @@ EDITS: 1
(if (not (provided? 'snd-nogui))
(let* ((snd (new-sound))
- (rd (make-readin "oboe.snd"))
- (ft (make-moving-fft rd))
+ (ft (make-moving-fft (make-readin "oboe.snd")))
(data (make-float-vector 256)))
(set! (lisp-graph?) #t)
(do ((i 0 (+ i 1)))
@@ -42640,14 +42271,11 @@ EDITS: 1
(test-sv)
(let ((rd (make-readin "1a.snd"))
- (cur-srate (mus-sound-srate "1a.snd"))
- (old-srate *clm-srate*))
- (set! *clm-srate* cur-srate)
- (let* ((scn (make-moving-pitch rd))
- (pitch (moving-pitch scn)))
- (if (not (>= 443.0 pitch 439.0))
- (snd-display ";moving-pitch 1a: ~A" pitch)))
- (set! *clm-srate* old-srate))
+ (cur-srate (mus-sound-srate "1a.snd")))
+ (let-temporarily ((*clm-srate* cur-srate))
+ (let ((pitch (moving-pitch (make-moving-pitch rd))))
+ (if (not (>= 443.0 pitch 439.0))
+ (snd-display ";moving-pitch 1a: ~A" pitch)))))
(let ((val (make-vector 3))
(frq 0.0))
@@ -42739,16 +42367,14 @@ EDITS: 1
(frqf (make-env '(0.000 0.220 0.074 0.249 0.133 0.249 0.194 0.240 0.258 0.252 0.324 0.264 0.389 0.267
0.456 0.270 0.520 0.264 0.847 0.270 0.920 0.273 1.000 0.279)
:duration 0.25 :scaler (hz->radians (* 0.5 0.205 22050.0))))
- (gen1 (make-polywave :partials (list 2 .35 3 .1 4 .8 5 .01 6 .03 8 .005)))
+ (gen1 (make-polywave :partials '(2 .35 3 .1 4 .8 5 .01 6 .03 8 .005)))
(rnd (make-rand-interp 600 (hz->radians 50))))
(lambda (dir)
(* (env ampf)
(polywave gen1 (+ (env frqf)
(rand-interp rnd)))))))
- (let* ((exp-amt 8.0)
- (dur 2.0)
- (samps (seconds->samples dur))
- (gran (make-granulate :expansion exp-amt :input ifunc)))
+ (let* ((samps (seconds->samples 2.0))
+ (gran (make-granulate :expansion 8.0 :input ifunc)))
(do ((i 0 (+ i 1)))
((= i samps))
(outa i (granulate gran)))))
@@ -42783,17 +42409,17 @@ EDITS: 1
(run gen)
(run gen)))
- (list 'nssb 'nxysin 'nxycos 'nxy1cos 'nxy1sin 'noddsin 'noddcos 'noddssb 'ncos2 'npcos
- 'nrsin 'nrcos 'nrssb 'nkssb 'nsincos 'rcos 'rssb 'rxysin 'rxycos
- 'rxyk!sin 'rxyk!cos 'ercos 'erssb 'eoddcos 'rkcos 'rksin 'rkssb
- 'rk!cos 'rk!ssb 'r2k!cos 'k2sin 'k2cos 'k2ssb 'dblsum 'rkoddssb 'krksin
- 'abcos 'absin 'r2k2cos 'bess 'jjcos 'j0evencos 'j2cos 'jpcos 'jncos
- 'j0j1cos 'jycos 'blackman 'fmssb 'k3sin 'izcos 'nchoosekcos 'n1cos
- 'adjustable-square-wave 'adjustable-triangle-wave 'adjustable-sawtooth-wave 'adjustable-oscil
- 'round-interp 'sinc-train 'pink-noise 'green-noise 'brown-noise 'green-noise-interp
- 'moving-max 'moving-norm 'moving-sum 'moving-rms 'moving-length 'weighted-moving-average 'exponentially-weighted-moving-average
- 'tanhsin 'moving-fft 'moving-scentroid 'moving-autocorrelation 'moving-pitch
- )
+ '(nssb nxysin nxycos nxy1cos nxy1sin noddsin noddcos noddssb ncos2 npcos
+ nrsin nrcos nrssb nkssb nsincos rcos rssb rxysin rxycos
+ rxyk!sin rxyk!cos ercos erssb eoddcos rkcos rksin rkssb
+ rk!cos rk!ssb r2k!cos k2sin k2cos k2ssb dblsum rkoddssb krksin
+ abcos absin r2k2cos bess jjcos j0evencos j2cos jpcos jncos
+ j0j1cos jycos blackman fmssb k3sin izcos nchoosekcos n1cos
+ adjustable-square-wave adjustable-triangle-wave adjustable-sawtooth-wave adjustable-oscil
+ round-interp sinc-train pink-noise green-noise brown-noise green-noise-interp
+ moving-max moving-norm moving-sum moving-rms moving-length weighted-moving-average exponentially-weighted-moving-average
+ tanhsin moving-fft moving-scentroid moving-autocorrelation moving-pitch)
+
gen-list
(list nssb? nxysin? nxycos? nxy1cos? nxy1sin? noddsin? noddcos? noddssb? ncos2? npcos?
@@ -42870,8 +42496,7 @@ EDITS: 1
(lambda (color-name)
(let* ((col (XColor))
(dpy (XtDisplay (cadr (main-widgets))))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(if (= (XAllocNamedColor dpy cmap color-name col col) 0)
(snd-error (format #f "can't allocate ~A" color-name))
(make-color-with-catch (/ (.red col) 65535.0)
@@ -43154,7 +42779,7 @@ EDITS: 1
(snd-display ";XExtendedMaxRequestSize ~A" (XExtendedMaxRequestSize dpy)))
(if (not (= (XMaxRequestSize dpy) 65535))
(snd-display ";XMaxRequestSize ~A" (XMaxRequestSize dpy)))
- (if (not (member (list 'Atom 40) (XListProperties dpy win)))
+ (if (not (member '(Atom 40) (XListProperties dpy win)))
(snd-display ";XListProperties: ~A" (XListProperties dpy win)))
(if (not (member "SHAPE" (XListExtensions dpy)))
(snd-display ";XListExtensions: ~A" (XListExtensions dpy)))
@@ -43189,8 +42814,7 @@ EDITS: 1
(let* ((col (XColor))
(col1 (XColor))
(dpy (XtDisplay (cadr (main-widgets))))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(if (= (XAllocNamedColor dpy cmap "blue" col col) 0) (snd-display ";XAllocNamedColor blue ~A?" col))
(if (not (= (.red col) 0)) (snd-display ";XAllocNamedColor: ~A" (.red col)))
(if (= (XAllocColor dpy cmap col) 0) (snd-display ";XAllocColor?"))
@@ -43203,7 +42827,7 @@ EDITS: 1
(XSetAfterFunction dpy (lambda (n) 0))
(XSetAfterFunction dpy #f)
- (if (not (equal? (XDisplayKeycodes dpy) (list 1 8 255)))
+ (if (not (equal? (XDisplayKeycodes dpy) '(1 8 255)))
(snd-display ";XDisplayKeycodes: ~A" (XDisplayKeycodes dpy)))
(let ((str (XFetchName dpy win)))
(if (not (string=? (substring str 0 3) "snd"))
@@ -43229,17 +42853,17 @@ EDITS: 1
(Window? (cadr focus))))
(snd-display ";XGetInputFocus: ~A" focus)))
(let ((vals (XGetPointerControl dpy)))
- (if (not (equal? vals (list 1 2 1 4))) (snd-display ";pointer state: ~A" vals))
+ (if (not (equal? vals '(1 2 1 4))) (snd-display ";pointer state: ~A" vals))
(XChangePointerControl dpy #f #t 2 1 8)
(set! vals (XGetPointerControl dpy))
- (if (not (equal? vals (list 1 2 1 8))) (snd-display ";set pointer state: ~A" vals))
+ (if (not (equal? vals '(1 2 1 8))) (snd-display ";set pointer state: ~A" vals))
(XChangePointerControl dpy #f #t 2 1 4))
(XAutoRepeatOff dpy)
(if (not (= ((XGetKeyboardControl dpy) 5) 0)) (snd-display ";AutoRepeatOff?"))
(XAutoRepeatOn dpy)
(if (not (= ((XGetKeyboardControl dpy) 5) 1)) (snd-display ";AutoRepeatOn?"))
(let ((vals (XGetPointerMapping dpy 0 3)))
- (if (not (equal? vals (list 1 2 3))) (snd-display ";XGetPointerMapping: ~A" vals)))
+ (if (not (equal? vals '(1 2 3))) (snd-display ";XGetPointerMapping: ~A" vals)))
(XGetScreenSaver dpy)
(XMoveWindow dpy win 100 10)
(XSync dpy #f)
@@ -43259,7 +42883,7 @@ EDITS: 1
(if (.backing_store attr) (snd-display ";XGetWindowAttributes backing_store: ~A" (.backing_store attr)))
(if (.override_redirect attr) (snd-display ";XGetWindowAttributes override_redirect: ~A" (.override_redirect attr)))
(if (.save_under attr) (snd-display ";XGetWindowAttributes save_under: ~A" (.save_under attr)))
- (if (not (equal? (.backing_pixel attr) (list 'Pixel 0))) (snd-display ";XGetWindowAttributes backing_pixel: ~A" (.backing_pixel attr)))
+ (if (not (equal? (.backing_pixel attr) '(Pixel 0))) (snd-display ";XGetWindowAttributes backing_pixel: ~A" (.backing_pixel attr)))
(if (not (= (.map_state attr) 2)) (snd-display ";XGetWindowAttributes map_state: ~A" (.map_state attr)))
(if (not (= (.your_event_mask attr) #x628033)) (snd-display ";your_event_mask: ~X" (.your_event_mask attr)))
(if (not (member (.all_event_masks attr) '(#x628033 #xe28033 #xea8033) =))
@@ -43307,7 +42931,7 @@ EDITS: 1
(lambda (func name)
(if (not (= (func cmap) 0)) (snd-display ";standardcolormap ~A: ~A" name (func cmap))))
(list .visualid .red_max .red_mult .green_max .green_mult .blue_max .blue_mult)
- (list 'visualid 'red_max 'red_mult 'green_max 'green_mult 'blue_max 'blue_mult))
+ '(visualid red_max red_mult green_max green_mult blue_max blue_mult))
(if (.colormap cmap) (snd-display ";colormap: ~A" (.colormap cmap)))
(XtFree (cadr cmap))
)
@@ -43316,7 +42940,7 @@ EDITS: 1
(lambda (func name)
(if (not (= (func icon) 0)) (snd-display ";iconsize ~A: ~A" name (func icon))))
(list .min_width .min_height .max_width .max_height .width_inc .height_inc)
- (list 'min_width 'min_height 'max_width 'max_height 'width_inc 'height_inc))
+ '(min_width min_height max_width max_height width_inc height_inc))
(XFree icon))
(let ((fs (XCreateFontSet dpy "*-*-*-*-Normal-*-*-*-*-*-*")))
@@ -43357,19 +42981,19 @@ EDITS: 1
(not (string=? (substring (car cmd) (- (length (car cmd)) 3)) "snd")))
(snd-display ";XGetCommand: ~A" cmd)))
(XSetCommand dpy win (list "hiho" "away") 2)
- (if (not (equal? (XGetCommand dpy win) (list "hiho" "away")))
+ (if (not (equal? (XGetCommand dpy win) '("hiho" "away")))
(snd-display ";XSetCommand: ~A" (XGetCommand dpy win)))
(let ((wmp (map (lambda (w) (XGetAtomName dpy w)) (XGetWMProtocols dpy win))))
- (if (not (equal? wmp (list "_MOTIF_WM_MESSAGES" "WM_DELETE_WINDOW")))
+ (if (not (equal? wmp '("_MOTIF_WM_MESSAGES" "WM_DELETE_WINDOW")))
(snd-display ";XGetWMProtocols: ~A" wmp)))
- (if (not (equal? (XListDepths dpy 0) (list 24 1 4 8 15 16 32)))
+ (if (not (equal? (XListDepths dpy 0) '(24 1 4 8 15 16 32)))
(snd-display ";XListDepths: ~A" (XListDepths dpy 0)))
(if (not (equal? (XListPixmapFormats dpy) '((1 1 32) (4 8 32) (8 8 32) (15 16 32) (16 16 32) (24 32 32) (32 32 32))))
(snd-display ";XListPixmapFormats: ~A" (XListPixmapFormats dpy)))
(XWarpPointer dpy (list 'Window None) (list 'Window None) 0 0 10 10 100 100)
(let ((cs (XQueryBestCursor dpy win 10 10)))
- (if (not (equal? cs (list 1 10 10))) (snd-display ";XQueryBestCursor: ~A" cs)))
+ (if (not (equal? cs '(1 10 10))) (snd-display ";XQueryBestCursor: ~A" cs)))
(let ((pt (XQueryPointer dpy win)))
(if (not (Window? (cadr pt))) (snd-display ";XQueryPointer: ~A" pt)))
(XRaiseWindow dpy win)
@@ -43392,7 +43016,7 @@ EDITS: 1
(if (not (.input hints)) (snd-display ";input wmhints: ~A" (.input hints)))
(if (not (Pixmap? (.icon_pixmap hints))) (snd-display ";icon_pixmap wmhints: ~A" (.icon_pixmap hints)))
(if (.icon_window hints) (snd-display ";icon_window: ~A" (.icon_window hints)))
- (if (not (equal? (.icon_mask hints) (list 'Pixmap 0))) (snd-display ";icon_mask: ~A" (.icon_mask hints)))
+ (if (not (equal? (.icon_mask hints) '(Pixmap 0))) (snd-display ";icon_mask: ~A" (.icon_mask hints)))
(if (not (number? (.window_group hints))) (snd-display ";window_group: ~A" (.window_group hints)))
(XtFree (cadr hints))
(let ((st (XAllocWMHints)))
@@ -43561,10 +43185,10 @@ EDITS: 1
(if (not (eqv? (.plane_mask val) 0))
(snd-display ";plane_mask: ~A ~A" (.plane_mask val) 0))
(set! (.tile val) (list 'Pixmap 0))
- (if (not (equal? (.tile val) (list 'Pixmap 0)))
+ (if (not (equal? (.tile val) '(Pixmap 0)))
(snd-display ";tile: ~A" (.tile val)))
(set! (.stipple val) (list 'Pixmap 0))
- (if (not (equal? (.stipple val) (list 'Pixmap 0)))
+ (if (not (equal? (.stipple val) '(Pixmap 0)))
(snd-display ";stipple: ~A" (.stipple val)))
(let* ((dpy (XtDisplay (cadr (main-widgets))))
@@ -43782,9 +43406,9 @@ EDITS: 1
(let ((obj (XTextItem "hiho" 4 3 (list 'Font 1))))
(if (not (XTextItem? obj)) (snd-display ";XTextItem -> ~A" obj))
- (if (not (equal? (.font obj) (list 'Font 1))) (snd-display ";font ~A" (.font obj)))
+ (if (not (equal? (.font obj) '(Font 1))) (snd-display ";font ~A" (.font obj)))
(set! (.font obj) (list 'Font 2))
- (if (not (equal? (.font obj) (list 'Font 2))) (snd-display ";set font ~A" (.font obj)))
+ (if (not (equal? (.font obj) '(Font 2))) (snd-display ";set font ~A" (.font obj)))
(if (not (string=? (.chars obj) "hiho")) (snd-display ";chars: ~A" (.chars obj)))
(if (not (= (.nchars obj) 4)) (snd-display ";chars: ~A" (.nchars obj)))
(set! (.chars obj) "away!")
@@ -43872,7 +43496,7 @@ EDITS: 1
;; ---------------- Xt tests ----------------
(let ((name (XtGetApplicationNameAndClass (XtDisplay (cadr (main-widgets))))))
- (if (not (equal? name (list "snd" "Snd")))
+ (if (not (equal? name '("snd" "Snd")))
(snd-display ";XtGetApplicationNameAndClass: ~A?" name)))
(let ((dpys (XtGetDisplays (car (main-widgets)))))
(if (not (Display? (car dpys)))
@@ -43997,11 +43621,11 @@ EDITS: 1
(if (not (KeySym? (cadr (XmTranslateKey dpy (list 'KeyCode XK_B) 0))))
(snd-display ";XmTranslateKey: ~A" (XmTranslateKey dpy XK_B 0)))
(let ((kv (XtKeysymToKeycodeList dpy (list 'KeySym 65509))))
- (if (not (equal? (car kv) (list 'KeyCode 66)))
+ (if (not (equal? (car kv) '(KeyCode 66)))
(snd-display ";XtKeysymToKeycodeList: ~A ~A" kv (XtKeysymToKeycodeList dpy (list 'KeySym 65509)))))
(XtInstallAllAccelerators (cadr (main-widgets)) (caddr (main-widgets)))
(XtInstallAccelerators (cadr (main-widgets)) (caddr (main-widgets)))
- (if (not (equal? (list 0 1 2) (XtSetArg 0 1 2))) (snd-display ";XtSetArg: ~A" (XtSetArg 0 1 2)))
+ (if (not (equal? '(0 1 2) (XtSetArg 0 1 2))) (snd-display ";XtSetArg: ~A" (XtSetArg 0 1 2)))
(if (not (Widget? (XtGetKeyboardFocusWidget (cadr (main-widgets)))))
(snd-display ";XtGetKeyboardFocusWidget: ~A" (XtGetKeyboardFocusWidget (cadr (main-widgets)))))
(XtRemoveInput (XtAppAddInput (car (main-widgets)) 1 XtInputReadMask (lambda (a b c) #f) #f))
@@ -44047,8 +43671,7 @@ EDITS: 1
(let ((ind (open-sound "oboe.snd")))
(set! (show-controls ind) #t)
- (let* ((swids (sound-widgets ind))
- (sctrls (swids 2))
+ (let* ((sctrls ((sound-widgets ind) 2))
(wh (widget-size sctrls)))
(XtUnmanageChild sctrls)
(set! (widget-size sctrls) (list (car wh) (* (cadr wh) 3)))
@@ -44069,7 +43692,7 @@ EDITS: 1
(XmRenderTableGetRenditions label-render-table (XmRenderTableGetTags label-render-table))))
(default-font-name (and renditions
(cadr (XmRenditionRetrieve (car renditions) (list XmNfontName 0)))))
- (default-font-info (and renditions
+ (default-font-info (and (pair? renditions)
(XmRenditionRetrieve (car renditions) (list XmNfont 0 XmNfontType 0)))))
(if (not (string=? default-font-name "fixed")) (snd-display ";XmRenderTableGetRenditions name: ~A" default-font-name))
(if (not (XFontStruct? (default-font-info 1))) (snd-display ";XmRenderTableGetRenditions font struct: ~A" default-font-info))
@@ -44081,7 +43704,7 @@ EDITS: 1
(XmRenderTableGetRendition button-render-table XmFONTLIST_DEFAULT_TAG)))
(default-font-info (and default-rendition
(XmRenditionRetrieve default-rendition (list XmNfont 0 XmNfontType 0)))))
- (if (and default-font-info
+ (if (and (pair? default-font-info)
(= (default-font-info 3) XmFONT_IS_FONT))
(let ((font (cadr default-font-info))
(dpy (XtDisplay (cadr (main-widgets))))
@@ -44100,7 +43723,7 @@ EDITS: 1
XA_FAMILY_NAME
(XInternAtom dpy "XA_FOUNDRY" #f)
XA_CAP_HEIGHT)
- (list #f #t #t #t #t #t #t #f))
+ '(#f #t #t #t #t #t #t #f))
(if (not (string=? "Fixed" (cadr (data 1)))) (snd-display ";XmRenderTableGetRendition: ~A" data)))))
(let* ((tabs (let ((ctr 0))
@@ -44108,20 +43731,20 @@ EDITS: 1
(lambda (n)
(set! ctr (+ ctr 1))
(XmTabCreate n XmINCHES (if (= ctr 1) XmABSOLUTE XmRELATIVE) XmALIGNMENT_BEGINNING "."))
- (list 1.5 1.5 1.5 1.5))))
+ '(1.5 1.5 1.5 1.5))))
(tablist (XmTabListInsertTabs #f tabs (length tabs) 0)))
(if (not (= (XmTabListTabCount tablist) (length tabs)))
(snd-display ";tablist len: ~A ~A~%" (XmTabListTabCount tablist) (length tabs)))
- (if (not (equal? (XmTabGetValues (XmTabListGetTab tablist 0)) (list 1.5 5 0 0 ".")))
+ (if (not (equal? (XmTabGetValues (XmTabListGetTab tablist 0)) '(1.5 5 0 0 ".")))
(snd-display ";XmTabs 0: ~A" (XmTabGetValues (XmTabListGetTab tablist 0))))
- (if (not (equal? (XmTabGetValues (XmTabListGetTab tablist 2)) (list 1.5 5 1 0 ".")))
+ (if (not (equal? (XmTabGetValues (XmTabListGetTab tablist 2)) '(1.5 5 1 0 ".")))
(snd-display ";XmTabs 2: ~A" (XmTabGetValues (XmTabListGetTab tablist 2))))
(let ((copytab (XmTabListCopy tablist 0 0)))
- (if (not (equal? (XmTabGetValues (XmTabListGetTab copytab 0)) (list 1.5 5 0 0 ".")))
+ (if (not (equal? (XmTabGetValues (XmTabListGetTab copytab 0)) '(1.5 5 0 0 ".")))
(snd-display ";XmTabListCopy 0: ~A" (XmTabGetValues (XmTabListGetTab copytab 0))))
(let ((another (XmTabListRemoveTabs copytab (list 0 1)))
(atab (XmTabCreate 3.0 XmINCHES XmABSOLUTE XmALIGNMENT_BEGINNING ".")))
- (if (not (equal? (XmTabGetValues (XmTabListGetTab another 0)) (list 1.5 5 1 0 ".")))
+ (if (not (equal? (XmTabGetValues (XmTabListGetTab another 0)) '(1.5 5 1 0 ".")))
(snd-display ";XmTabListRemoveTabs: ~A" (XmTabGetValues (XmTabListGetTab another 0))))
(XmTabListReplacePositions (XmTabListCopy tablist 0 0) (list 1) (list atab))
;; this (replacepositions) is very prone to segfaults -- *very* poorly implemented!
@@ -44141,7 +43764,7 @@ EDITS: 1
(snd-display ";host name appears to be ~A or maybe ~A" hname (getenv "HOSTNAME"))))
(let ((blu (x->snd-color "blue")))
(if (not (Pixel? blu)) (snd-display ";x->snd-color can't find blue! ~A" blu))
- (if (not (equal? (color->list blu) (list 0.0 0.0 1.0)))
+ (if (not (equal? (color->list blu) '(0.0 0.0 1.0)))
(snd-display ";x->snd-color blue: ~A" (color->list blu))))
(let* ((tmp (XmStringCreateLocalized "h"))
@@ -44167,11 +43790,9 @@ EDITS: 1
"-*-*-medium-i-*-*-18-*-*-*-*-*-*-*"
"-*-helvetica-*-*-*-*-18-*-*-*-*-*-*-*"))
(tags (list "one" "two" "three" "four"))
- (colors (list "red" "green" "blue" "orange"))
(pixels
(let* ((dpy (XtDisplay (cadr (main-widgets))))
- (scr (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr)))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy))))
(let ((col (XColor)))
(XParseColor dpy cmap "blue" col)
(if (not (and (= (.red col) 0)
@@ -44189,7 +43810,7 @@ EDITS: 1
(if (= (XAllocNamedColor dpy cmap color col col) 0)
(snd-error (format #f "can't allocate ~A" color))
(.pixel col))))
- colors)))
+ '("red" "green" "blue" "orange"))))
(rendertable (XmRenderTableAddRenditions #f
(let ((ctr 0))
(map (lambda (r)
@@ -44219,7 +43840,7 @@ EDITS: 1
(let ((tabl (XmStringTableParseStringArray (list "hi" "ho") 2 "hiho" XmCHARSET_TEXT #f 0 #f)))
(if (not (XmString? (car tabl))) (snd-display ";XmStringTableParseStringArray: ~A" tabl))
(let ((strs (XmStringTableUnparse tabl 2 "hiho" XmCHARSET_TEXT XmCHARSET_TEXT #f 0 XmOUTPUT_ALL)))
- (if (not (equal? strs (list "hi" "ho"))) (snd-display ";XmStringTableUnparse: ~A" strs)))
+ (if (not (equal? strs '("hi" "ho"))) (snd-display ";XmStringTableUnparse: ~A" strs)))
(let ((str (XmStringTableToXmString tabl 2 #f)))
(if (not (XmString? str)) (snd-display ";XmStringTableToXmString: ~A" str))
(XmStringToXmStringTable str #f)
@@ -44232,8 +43853,7 @@ EDITS: 1
(grf1 (car (channel-widgets)))
(dpy (XtDisplay grf1))
(win (XtWindow grf1))
- (scr (DefaultScreenOfDisplay dpy))
- (scrn (XScreenNumberOfScreen scr))
+ (scrn (XScreenNumberOfScreen (DefaultScreenOfDisplay dpy)))
(gv (XGCValues)))
(if (not (Font? (current-font ind))) (snd-display ";current-font: ~A" (current-font ind)))
(let ((old-font (current-font))
@@ -44277,7 +43897,7 @@ EDITS: 1
(if (not (XmStringHasSubstring str (XmStringCreateLocalized "hi"))) (snd-display ";XmStringHasSubstring?"))))
- (if (not (equal? (XmRenderTableGetTags rendertable) (list "one" "two" "three" "four")))
+ (if (not (equal? (XmRenderTableGetTags rendertable) '("one" "two" "three" "four")))
(snd-display ";tags: ~A~%" (XmRenderTableGetTags rendertable)))
(let* ((rend (XmRenderTableGetRendition rendertable "one"))
(r (and rend (XmRenditionRetrieve rend
@@ -44296,7 +43916,7 @@ EDITS: 1
(snd-display ";r and rend: ~A ~A~%" r rend)))
(XmRenditionFree (XmRenditionCreate (cadr (main-widgets)) "r1" (list XmNfontName "fixed")))
- (if (not (equal? (XmDropSiteQueryStackingOrder ((main-widgets) 4)) (list #f)))
+ (if (not (equal? (XmDropSiteQueryStackingOrder ((main-widgets) 4)) '(#f)))
(snd-display ";XmDropSiteQueryStackingOrder: ~A" (XmDropSiteQueryStackingOrder ((main-widgets) 4))))
(let ((tab (XmStringComponentCreate XmSTRING_COMPONENT_TAB 0 #f))
(row #f)
@@ -44322,11 +43942,10 @@ EDITS: 1
(set! our-tags tags)
(set! table (cons row table))
(set! row #f))))
- (list "this" "is" "a" "test" "of" "the" "renditions" "and" "rendertables"
+ '("this" "is" "a" "test" "of" "the" "renditions" "and" "rendertables"
"perhaps" "all" "will" "go" "well" "and" "then" "again" "perhaps" "not"))
- (let* ((n (car table))
- (c (XmStringInitContext n))
- (happy #t))
+ (let ((c (XmStringInitContext (car table)))
+ (happy #t))
(do ((i 0 (+ i 1)))
((not happy))
(let ((type (XmStringGetNextTriple (cadr c))))
@@ -44382,8 +44001,7 @@ EDITS: 1
(win (XtWindow grf1))
(sgc (car (snd-gcs)))
(shell (cadr (main-widgets)))
- (scr (DefaultScreen dpy))
- (vis (DefaultVisual dpy scr))
+ (vis (DefaultVisual dpy (DefaultScreen dpy)))
(depth (cadr (XtGetValues grf1 (list XmNdepth 0))))
(pix (XCreatePixmap dpy win 10 10 depth))
(rotpix (XCreatePixmap dpy win 10 10 depth)))
@@ -44524,8 +44142,8 @@ EDITS: 1
(set! (func attr) val)
(if (not (equal? (func attr) val)) (snd-display ";attr ~A ~A" name (func attr))))
(list .valuemask .depth .width .x_hotspot .y_hotspot .cpp .npixels .ncolors)
- (list 0 0 0 0 0 0 0 0)
- (list 'valuemask 'depth 'width 'x_hotspot 'y_hotspot 'cpp 'npixels 'ncolors))))
+ '(0 0 0 0 0 0 0 0)
+ '(valuemask depth width x_hotspot y_hotspot cpp npixels ncolors))))
(XDestroyImage i11)))
(XFreePixmap dpy pix)
@@ -44560,9 +44178,9 @@ EDITS: 1
; these are causing: X Error of failed request: BadAccess (attempt to access private resource denied)
; (if (not (equal? (XGetTransientForHint dpy win) (list 0 #f)))
; (snd-display ";XGetTransientForHint: ~A" (XGetTransientForHint dpy win)))
- (if (not (equal? (XGetErrorText dpy BadColor #f 9) (list 0 "BadColor")))
+ (if (not (equal? (XGetErrorText dpy BadColor #f 9) '(0 "BadColor")))
(snd-display ";XGetErrorText: ~A" (XGetErrorText dpy BadColor #f 9)))
- (if (not (equal? (XGeometry dpy 0 "500x400" "500x400+10+10" 4 7 14 2 2) (list 12 10 10 500 400)))
+ (if (not (equal? (XGeometry dpy 0 "500x400" "500x400+10+10" 4 7 14 2 2) '(12 10 10 500 400)))
(snd-display ";XGeometry: ~A" (XGeometry dpy 0 "500x400" "500x400+10+10" 4 7 14 2 2)))
(if (< (XEventsQueued dpy QueuedAlready) 0)
(snd-display ";XEventsQueued: ~A" (XEventsQueued dpy QueuedAlready)))
@@ -44932,8 +44550,7 @@ EDITS: 1
(snd-display ";text type check: ~A" tag)))
(let ((dpy (XtDisplay (cadr (main-widgets))))
(win (XtWindow (cadr (main-widgets)))))
- (let* ((app (car (main-widgets)))
- (tag (catch #t (lambda () (XtDisplayInitialize app dpy "hi" "ho" 1 1)) (lambda args (car args)))))
+ (let ((tag (catch #t (lambda () (XtDisplayInitialize (car (main-widgets)) dpy "hi" "ho" 1 1)) (lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg)) (snd-display ";XtDisplayInitialize type check: ~A" tag)))
(let ((tag (catch #t (lambda () (XmTransferSetParameters 123 123 123 123 "hiho")) (lambda args (car args)))))
(if (not (eq? tag 'wrong-type-arg)) (snd-display ";XmTransferSetParameters type check: ~A" tag)))
@@ -45267,8 +44884,7 @@ EDITS: 1
(XmSetColorCalculation #f)
(let* ((dpy (XtDisplay (cadr (main-widgets))))
- (scr1 (DefaultScreen dpy))
- (cmap (DefaultColormap dpy scr1))
+ (cmap (DefaultColormap dpy (DefaultScreen dpy)))
(screen (XDefaultScreenOfDisplay dpy))
(scr (XmGetXmScreen (XDefaultScreenOfDisplay dpy)))
;(old-h (cadr (XtVaGetValues scr (list XmNhorizontalFontUnit 0))))
@@ -45377,15 +44993,15 @@ EDITS: 1
; )))))
; (XtUnmanageChild box))
(let ((hi (XtCreateManagedWidget "hi" xmTextWidgetClass (cadr (main-widgets))
- (list XmNqualifySearchDataProc (lambda (w c i) "hi")
- XmNtransferProc (lambda (a b c d e f g) "ho")
+ (list XmNqualifySearchDataProc (lambda (w c i) (copy "hi"))
+ XmNtransferProc (lambda (a b c d e f g) (copy "ho"))
XmNcolorAllocationProc (lambda (a b c) #f)
XmNcolorCalculationProc (lambda (a b) #f)
XmNcreatePopupChildProc (lambda (a) #f)
XmNlargeIconX 0.5
))))
- (XtVaSetValues hi (list XmNqualifySearchDataProc (lambda (w c i) "hi")
- XmNtransferProc (lambda (a b c d e f g) "ho")
+ (XtVaSetValues hi (list XmNqualifySearchDataProc (lambda (w c i) (copy "hi"))
+ XmNtransferProc (lambda (a b c d e f g) (copy "ho"))
XmNcolorAllocationProc (lambda (a b c) #f)
XmNcolorCalculationProc (lambda (a b) #f)
XmNcreatePopupChildProc (lambda (a) #f)))
@@ -45725,7 +45341,7 @@ EDITS: 1
((uchar) (set! ((car field) struct) val))
((Widget) (set! ((car field) struct) (list 'Widget 0)))
((XmString) (set! ((car field) struct) (list 'XmString 0)))
- ((char*) (set! ((car field) struct) "hi"))
+ ((char*) (set! ((car field) struct) (copy "hi")))
((XEvent Boolean XmString* int* Time Window Widget* Screen) #f)
)))
(cdr call))))
@@ -45973,10 +45589,9 @@ EDITS: 1
(if (not (list? vals)) (snd-display ";XShapeGetRectangles: ~A" vals))
;(segfault) (XtFree (cadr vals))
(set! vals (XShapeQueryExtension dpy))
- (if (not (equal? vals (list #t 64 0))) (snd-display ";XShapeQueryExtension: ~A" vals))
+ (if (not (equal? vals '(#t 64 0))) (snd-display ";XShapeQueryExtension: ~A" vals))
(set! vals (XShapeQueryVersion dpy))
- (if (not (or (equal? vals (list #t 1 0))
- (equal? vals (list #t 1 1))))
+ (if (not (member vals '((#t 1 0) (#t 1 1))))
(snd-display ";XShapeQueryVersion: ~A" vals))
(if (XShapeOffsetShape dpy win 0 0 0) (snd-display ";XShapeOffsetShape?"))
@@ -46009,10 +45624,9 @@ EDITS: 1
(wids ()))
(for-each
(lambda (class)
- (let* ((shell (cadr (main-widgets)))
- (wid (XtCreateWidget "hiho" class shell ())))
+ (let ((wid (XtCreateWidget "hiho" class (cadr (main-widgets)) ())))
(set! wids (cons wid wids))
- (XtAddCallback wid XmNhelpCallback (lambda (w c i) "help!"))))
+ (XtAddCallback wid XmNhelpCallback (lambda (w c i) (copy "help!")))))
classes)
(for-each
(lambda (w)
@@ -46296,7 +45910,7 @@ EDITS: 1
(lambda args (car args))))
xm-procs1))
(list win 1.5 "/hiho" (list 0 1) 1234 (make-float-vector 3) (make-color-with-catch .95 .95 .95) #(0 1) 3/4 'mus-error 0+i (make-delay 32)
- (lambda () #t) (curlet) (make-float-vector (list 2 3) 0.0) :order 0 1 -1 #f #t () #()))
+ (lambda () #t) (curlet) (make-float-vector '(2 3)) :order 0 1 -1 #f #t () #()))
;; ---------------- 2 Args
(for-each
@@ -46531,7 +46145,7 @@ EDITS: 1
(lambda () (n arg))
(lambda args (car args))))
gl-procs))
- (list (list 0 1) 0+i))
+ '((0 1) 0+i))
(when (pair? glu-procs)
(for-each
@@ -46542,7 +46156,7 @@ EDITS: 1
(lambda () (n arg))
(lambda args (car args))))
gl-procs))
- (list (list 0 1) 0+i))
+ '((0 1) 0+i))
(let ((ind (open-sound "oboe.snd")))
(glXMakeCurrent ((*motif* 'XtDisplay) (cadr (main-widgets)))
@@ -46611,8 +46225,7 @@ EDITS: 1
(and (procedure? (procedure-setter func))
(arity (procedure-setter func))))))
(and (pair? arit)
- (>= args (car arit))
- (<= args (cdr arit)))))
+ (<= (car arit) args (cdr arit)))))
(when with-gui ; to the end!
(let* ((delay-32 (make-delay 32))
@@ -46882,7 +46495,7 @@ EDITS: 1
(set! a-hook (float-vector 0.2 0.1)))
((4)
(set! delay-32 (make-filter 3 (float-vector 3 1 2 3) (float-vector 3 1 2 3)))
- (set! color-95 (make-float-vector (list 2 1) 0.0))
+ (set! color-95 (make-float-vector '(2 1)))
(set! vector-0 (make-iir-filter 3 (float-vector 1 2 3)))
(set! float-vector-3 (make-ncos))
(set! car-main (make-env '(0 0 1 1) :length 101))
@@ -47017,12 +46630,10 @@ EDITS: 1
(list float-vector-add! float-vector-subtract! float-vector-multiply! float-vector-ref float-vector-scale!)))
(list (make-vector 1) "hiho" 0+i (list 1 0) #(0 1) delay-32))
- (let* ((v float-vector-3)
- (tag
- (catch #t
- (lambda ()
- (v 12))
- (lambda args (car args)))))
+ (let ((tag (catch #t
+ (lambda ()
+ (float-vector-3 12))
+ (lambda args (car args)))))
(if (not (eq? tag 'out-of-range))
(snd-display ";float-vector[12]: ~A" tag)))
@@ -47353,7 +46964,7 @@ EDITS: 1
(if (not (memq tag '(error wrong-type-arg syntax-error)))
(snd-display ";[0]: mix procs ~A: ~A (~A)" b tag float-vector-5))))
(list mix-amp mix-amp-env mix-length mix-name mix-position mix-home mix-speed mix-tag-y)
- (list 'mix-amp 'mix-amp-env 'mix-length 'mix-name 'mix-position 'mix-home 'mix-speed 'mix-tag-y))
+ '(mix-amp mix-amp-env mix-length mix-name mix-position mix-home mix-speed mix-tag-y))
(for-each (lambda (n)
(let ((tag
@@ -47386,7 +46997,7 @@ EDITS: 1
(if (not (memq tag '(error wrong-type-arg syntax-error)))
(snd-display ";[3]: mix procs ~A: ~A (~A)" b tag float-vector-5))))
(list mix-name mix-position mix-home mix-speed mix-tag-y)
- (list 'mix-name 'mix-position 'mix-home 'mix-speed 'mix-tag-y))
+ '(mix-name mix-position mix-home mix-speed mix-tag-y))
(close-sound index))
(if (sound? (find-sound "oboe.snd"))
(snd-display ";oboe.snd is still open?"))
@@ -47527,12 +47138,12 @@ EDITS: 1
(check-error-tag 'mus-error (lambda () (mus-sound-chans (string-append sf-dir "bad_field.nist"))))
(check-error-tag 'mus-error (lambda () (make-locsig 1/0 :channels 2)))
(when (provided? 'snd-motif)
- (check-error-tag 'no-such-widget (lambda () (widget-position (list 'Widget 0)))) ; dubious -- not sure these should be supported
- (check-error-tag 'no-such-widget (lambda () (widget-size (list 'Widget 0))))
- (check-error-tag 'no-such-widget (lambda () (widget-text (list 'Widget 0))))
- (check-error-tag 'no-such-widget (lambda () (set! (widget-position (list 'Widget 0)) (list 0 0))))
- (check-error-tag 'no-such-widget (lambda () (set! (widget-size (list 'Widget 0)) (list 10 10))))
- (check-error-tag 'no-such-widget (lambda () (set! (widget-text (list 'Widget 0)) "hiho"))))
+ (check-error-tag 'no-such-widget (lambda () (widget-position '(Widget 0)))) ; dubious -- not sure these should be supported
+ (check-error-tag 'no-such-widget (lambda () (widget-size '(Widget 0))))
+ (check-error-tag 'no-such-widget (lambda () (widget-text '(Widget 0))))
+ (check-error-tag 'no-such-widget (lambda () (set! (widget-position '(Widget 0)) (list 0 0))))
+ (check-error-tag 'no-such-widget (lambda () (set! (widget-size '(Widget 0)) (list 10 10))))
+ (check-error-tag 'no-such-widget (lambda () (set! (widget-text '(Widget 0)) "hiho"))))
(check-error-tag 'no-such-menu (lambda () (main-menu -1)))
(check-error-tag 'no-such-menu (lambda () (main-menu 111)))
(check-error-tag 'out-of-range (lambda () (new-sound "hiho" :header-type 123)))
@@ -47551,7 +47162,7 @@ EDITS: 1
(select-all)
(check-error-tag 'mus-error (lambda () (save-selection "sel0.snd" :not-a-key 3)))
(check-error-tag 'wrong-type-arg (lambda () (read-only (list ind))))
- (check-error-tag 'wrong-type-arg (lambda () (framples ind (list 0))))
+ (check-error-tag 'wrong-type-arg (lambda () (framples ind '(0))))
(check-error-tag 'wrong-type-arg (lambda () (smooth-sound 0 -10)))
(check-error-tag 'no-such-channel (lambda () (mix-selection 0 ind 123)))
(check-error-tag 'no-such-channel (lambda () (insert-selection 0 ind 123)))
@@ -47692,10 +47303,10 @@ EDITS: 1
(check-error-tag 'out-of-range (lambda () (env-sound '(0 0 1 1) 0 #f -1.5)))
(check-error-tag 'out-of-range (lambda () (xramp-channel 0.0 1.0 -1.6)))
(check-error-tag 'wrong-type-arg (lambda () (set! (samples 0 2) -1)))
- (check-error-tag 'wrong-type-arg (lambda () (left-sample (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (amp-control (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (sound-loop-info (list 0))))
- (check-error-tag 'wrong-type-arg (lambda () (add-mark 123 (list 0))))
+ (check-error-tag 'wrong-type-arg (lambda () (left-sample '(0))))
+ (check-error-tag 'wrong-type-arg (lambda () (amp-control '(0))))
+ (check-error-tag 'wrong-type-arg (lambda () (sound-loop-info '(0))))
+ (check-error-tag 'wrong-type-arg (lambda () (add-mark 123 '(0))))
(check-error-tag 'no-such-sound (lambda () (filter-channel '(0 0 1 1) 100 #f #f 1234 0)))
(check-error-tag 'no-such-channel (lambda () (filter-channel '(0 0 1 1) 100 #f #f ind 1)))
(check-error-tag 'no-such-channel (lambda () (filter-channel (float-vector 0 0 1 1) 4 #f #f ind 1)))
@@ -47757,7 +47368,7 @@ EDITS: 1
(check-error-tag 'mus-error (lambda () (set! (mus-xcoeff (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3) 4) 1.0)))
(check-error-tag 'mus-error (lambda () (set! (mus-ycoeff (make-filter 3 :xcoeffs float-vector-3 :ycoeffs float-vector-3) 4) 1.0)))
(check-error-tag 'mus-error (lambda () (make-filter :ycoeffs (make-float-vector 4) :order 12)))
- (check-error-tag 'mus-error (lambda () (let ((hi (make-oscil))) (set! (mus-offset hi) 1))))
+ (check-error-tag 'mus-error (lambda () (set! (mus-offset (make-oscil)) 1)))
(check-error-tag 'out-of-range (lambda () (make-locsig :channels (expt 2 30))))
(check-error-tag 'out-of-range (lambda () (make-src :width 3000)))
(check-error-tag 'bad-arity (lambda () (add-colormap "baddy" (lambda () #f))))
@@ -47791,7 +47402,7 @@ EDITS: 1
(check-error-tag 'wrong-type-arg (lambda () (set! *ask-about-unsaved-edits* 123)))
(check-error-tag 'no-such-mix (lambda () (mix-properties (integer->mix (+ 1 (mix-sync-max))))))
- (check-error-tag 'no-such-mix (lambda () (set! (mix-properties (integer->mix (+ 1 (mix-sync-max)))) 1)))
+ (check-error-tag 'no-such-mix (lambda () (set! (mix-properties (integer->mix (+ 1 (mix-sync-max)))) '(a 1))))
)
;; xen.h over-optimization regression check
@@ -47829,7 +47440,7 @@ EDITS: 1
(if (not (eq? tag 'no-such-widget))
(snd-display ";~A of null widget -> ~A" name tag))))
(list widget-position widget-size widget-text hide-widget show-widget focus-widget)
- (list 'widget-position 'widget-size 'widget-text 'hide-widget 'show-widget 'focus-widget)))
+ '(widget-position widget-size widget-text hide-widget show-widget focus-widget)))
;; ---------------- key args
(for-each
diff --git a/snd-xen.c b/snd-xen.c
index 6fed1d5..91ab46c 100644
--- a/snd-xen.c
+++ b/snd-xen.c
@@ -2708,7 +2708,7 @@ Xen_wrap_1_arg(g_snd_warning_w, g_snd_warning)
void g_xen_initialize(void)
{
#if HAVE_SCHEME
- s7_pointer pl_dr, pl_dir, pl_ss, pl_b, pl_pr;
+ s7_pointer pl_dr, pl_dir, pl_ss, pl_b, pl_prr;
#if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
s7_pointer pl_pf;
#endif
@@ -2828,7 +2828,7 @@ be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val').
p = s7_make_symbol(s7, "pair?");
pl_ss = s7_make_signature(s7, 2, s, s);
pl_dr = s7_make_circular_signature(s7, 1, 2, d, r);
- pl_pr = s7_make_signature(s7, 2, p, r);
+ pl_prr = s7_make_signature(s7, 3, p, r, r);
pl_dir = s7_make_signature(s7, 3, d, i, r);
pl_b = s7_make_signature(s7, 1, b);
#if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
@@ -2867,7 +2867,7 @@ be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val').
Xen_define_typed_procedure(S_bes_kn, g_kn_w, 2, 0, 0, H_kn, pl_dir);
Xen_define_typed_procedure("gsl-ellipk", g_gsl_ellipk_w, 1, 0, 0, H_gsl_ellipk, pl_dr);
- Xen_define_typed_procedure("gsl-ellipj", g_gsl_ellipj_w, 2, 0, 0, H_gsl_ellipj, pl_pr);
+ Xen_define_typed_procedure("gsl-ellipj", g_gsl_ellipj_w, 2, 0, 0, H_gsl_ellipj, pl_prr);
#if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
Xen_define_typed_procedure("gsl-eigenvectors", g_gsl_eigenvectors_w, 1, 0, 0, "returns eigenvalues and eigenvectors", pl_pf);
diff --git a/snd-xref.c b/snd-xref.c
index c053965..a2e428c 100644
--- a/snd-xref.c
+++ b/snd-xref.c
@@ -1762,7 +1762,7 @@ static const char *Reverb_urls[] = {
#if HAVE_SCHEME
-static const char *snd_names[11622] = {
+static const char *snd_names[11630] = {
"*clm-array-print-length*", "ws.scm",
"*clm-channels*", "ws.scm",
"*clm-clipped*", "ws.scm",
@@ -1792,6 +1792,7 @@ static const char *snd_names[11622] = {
"*libgdbm*", "libgdbm.scm",
"*libgsl*", "libgsl.scm",
"*libm*", "libm.scm",
+ "*lint*", "lint.scm",
"*mock-char*", "mockery.scm",
"*mock-hash-table*", "mockery.scm",
"*mock-number*", "mockery.scm",
@@ -3719,6 +3720,7 @@ static const char *snd_names[11622] = {
"bytevector-copy", "r7rs.scm",
"bytevector-copy!", "r7rs.scm",
"bytevector-length", "r7rs.scm",
+ "bytevector-u8", "r7rs.scm",
"bytevector-u8-ref", "r7rs.scm",
"bytevector-u8-set!", "r7rs.scm",
"c-define", "cload.scm",
@@ -4175,6 +4177,7 @@ static const char *snd_names[11622] = {
"files-popdown-info", "nb.scm",
"files-popup-info", "nb.scm",
"fill-in", "musglyphs.scm",
+ "fill-rectangle-1", "musglyphs.scm",
"fillfnc", "jcvoi.scm",
"filter-fft", "examp.scm",
"filter-selection-and-smooth", "selection.scm",
@@ -6512,6 +6515,7 @@ static const char *snd_names[11622] = {
"make-krksin", "generators.scm",
"make-literal-path", "dlocsig.scm",
"make-literal-polar-path", "dlocsig.scm",
+ "make-local-biquad", "dsp.scm",
"make-local-method", "mockery.scm",
"make-lowpass", "dsp.scm",
"make-method", "mockery.scm",
@@ -7578,7 +7582,7 @@ static const char *snd_names[11622] = {
static void autoload_info(s7_scheme *sc)
{
- s7_autoload_set_names(sc, snd_names, 5811);
+ s7_autoload_set_names(sc, snd_names, 5815);
}
#endif
diff --git a/snd.h b/snd.h
index 99a0dec..9b41282 100644
--- a/snd.h
+++ b/snd.h
@@ -53,11 +53,11 @@
#include "snd-strings.h"
-#define SND_DATE "9-May-16"
+#define SND_DATE "15-June-16"
#ifndef SND_VERSION
-#define SND_VERSION "16.5"
+#define SND_VERSION "16.6"
#endif
#define SND_MAJOR_VERSION "16"
-#define SND_MINOR_VERSION "5"
+#define SND_MINOR_VERSION "6"
#endif
diff --git a/snd.html b/snd.html
index 45ef1ff..1f4f3bd 100644
--- a/snd.html
+++ b/snd.html
@@ -884,7 +884,7 @@ window size:</p>
;; if so, set the FFT size to reflect the graph boundaries
(if (and (<a class=quiet href="extsnd.html#transformgraphp">transform-graph?</a>)
(= (<a class=quiet href="extsnd.html#transformgraphtype">transform-graph-type</a>) <a class=quiet href="extsnd.html#transformgraphtype">graph-once</a>))
- (let ((size (expt 2 (ceiling (log (+ 1.0 (- (<a class=quiet href="extsnd.html#rightsample">right-sample</a>) (<a class=quiet href="extsnd.html#leftsample">left-sample</a>))) 2.0)))))
+ (let ((size (expt 2 (ceiling (log (- (+ 1.0 (right-sample)) (left-sample)) 2.0)))))
(if (not (= size (<a class=quiet href="extsnd.html#transformsize">transform-size)</a>))
(set! (<a class=quiet href="extsnd.html#transformsize">transform-size)</a> size))))))
</pre>
diff --git a/sndclm.html b/sndclm.html
index e1865a9..800eccc 100644
--- a/sndclm.html
+++ b/sndclm.html
@@ -814,7 +814,7 @@ This means that the frequency envelope y values should be passed through <a href
<pre class="indented">
(define (simp start end freq amp frq-env)
(let ((os (make-oscil freq))
- (frqe (<a class=quiet href="#make-env">make-env</a> frq-env :length (+ 1 (- end start)) :scaler (<em class=red>hz->radians</em> freq))))
+ (frqe (<a class=quiet href="#make-env">make-env</a> frq-env :length (- (+ end 1) start) :scaler (<em class=red>hz->radians</em> freq))))
(do ((i start (+ i 1)))
((= i end))
(<a class=quiet href="#outa">outa</a> i (* amp (oscil os (<a class=quiet href="#env">env</a> <em class=red>frqe</em>)))))))
@@ -1751,9 +1751,8 @@ based on some previously chosen loop positions:
(<= (cadr loop-data) (car loop-data)))
(error 'no-loop-positions)
(let* ((loop-start (car loop-data))
- (loop-end (cadr loop-data))
- (loop-length (+ 1 (- loop-end loop-start)))
- (sound-section (<a class=quiet href="#filetoarray">file->array</a> sound 0 loop-start loop-length (make-float-vector loop-length 0.0)))
+ (loop-length (- (+ (cadr loop-data) 1) loop-start))
+ (sound-section (<a class=quiet href="#filetoarray">file->array</a> sound 0 loop-start loop-length (make-float-vector loop-length)))
(original-loop-duration (/ loop-length (srate sound)))
(tbl (<em class=red>make-table-lookup</em> :frequency (/ freq original-loop-duration) :wave sound-section)))
;; "freq" here is how fast we read (transpose) the sound — 1.0 returns the original
@@ -1774,7 +1773,7 @@ modulation deviation in samples:
(end (+ beg (<a class=quiet href="#secondstosamples">seconds->samples</a> dur)))
(table-length (<a class=quiet href="extsnd.html#mussoundframples">mus-sound-framples</a> file))
(tab (<em class=red>make-table-lookup</em> :frequency (/ read-speed (<a class=quiet href="extsnd.html#mussoundduration">mus-sound-duration</a> file))
- :wave (<a class=quiet href="#filetoarray">file->array</a> file 0 0 table-length (make-float-vector table-length 0.0))))
+ :wave (<a class=quiet href="#filetoarray">file->array</a> file 0 0 table-length (make-float-vector table-length))))
(osc (<a class=quiet href="#make-oscil">make-oscil</a> modulator-freq))
(index (/ (* (<a class=quiet href="#hztoradians">hz->radians</a> modulator-freq) 2 pi index-in-samples) table-length)))
(do ((i beg (+ i 1)))
@@ -1803,7 +1802,7 @@ the table-relative phase, returning a squared-off sine-wave:
<!--
(with-sound (:srate 1000000 :channels 2)
- (let ((gen1 (make-table-lookup 100.0 :wave (partials->wave '(1 1) (make-float-vector 100 0.0)) :type mus-interp-none))
+ (let ((gen1 (make-table-lookup 100.0 :wave (partials->wave '(1 1) (make-float-vector 100)) :type mus-interp-none))
(sine (make-oscil 100.0)))
(do ((i 0 (+ i 1)))
((= i 1000000))
@@ -1843,7 +1842,7 @@ reduces the original problem by a factor of n * L:
<!--
(with-sound (:srate 1000000 :channels 2)
- (let ((gen1 (make-table-lookup 100.0 :wave (partials->wave '(1 1) (make-float-vector 100 0.0)) :type mus-interp-linear))
+ (let ((gen1 (make-table-lookup 100.0 :wave (partials->wave '(1 1) (make-float-vector 100)) :type mus-interp-linear))
(sine (make-oscil 100.0)))
(do ((i 0 (+ i 1)))
((= i 1000000))
@@ -1895,10 +1894,10 @@ If you're trying to produce a sum of sinusoids, use polywave — it makes a
(with-sound (:channels 4 :clipped #f :statistics #t)
(let* ((pitch 1000.0)
(size 64)
- (tbl1 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size 0.0)) size mus-interp-none))
- (tbl2 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size 0.0)) size mus-interp-linear))
- (tbl3 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size 0.0)) size mus-interp-lagrange))
- (tbl4 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size 0.0)) size mus-interp-hermite)))
+ (tbl1 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size)) size mus-interp-none))
+ (tbl2 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size)) size mus-interp-linear))
+ (tbl3 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size)) size mus-interp-lagrange))
+ (tbl4 (make-table-lookup pitch 0.0 (partials->wave '(1 1) (make-float-vector size)) size mus-interp-hermite)))
(do ((i 0 (+ i 1)))
((= i 100000))
(outa i (table-lookup tbl1))
@@ -1909,7 +1908,7 @@ If you're trying to produce a sum of sinusoids, use polywave — it makes a
(with-sound (:channels 5 :clipped #f :statistics #t)
(let* ((pitch 2.0)
(size 64)
- (wave (let ((v (make-float-vector size 0.0 0.0)))
+ (wave (let ((v (make-float-vector size)))
(set! (v (/ size 2)) 1.0)
v))
(tbl1 (make-table-lookup pitch 0.0 wave size mus-interp-none))
@@ -2188,7 +2187,7 @@ in phase and amplitude at run-time by setting a float-vector value.
<pre class="indented">
(<a class=quiet href="sndscm.html#wsdoc">with-sound</a> (:clipped #f :statistics #t :play #t :scaled-to .5)
(let ((gen (<em class=red>make-polywave</em> 200
- (do ((harms (make-float-vector (* 5 2) 0.0)) ; 5 harmonics, 2 numbers for each
+ (do ((harms (make-float-vector (* 5 2))) ; 5 harmonics, 2 numbers for each
(k 1 (+ k 3))
(i 0 (+ i 2)))
((= i 10) harms)
@@ -2531,8 +2530,8 @@ we get sum and difference tones, much as in complex FM:
(do ((i 0 (+ i 1)))
((= i 44100))
(<a class=quiet href="#outa">outa</a> i (<em class=red>polynomial</em> pcoeffs
- (* 0.5 (+ (<a class=quiet href="#oscil">oscil</a> gen1))
- (<a class=quiet href="#oscil">oscil</a> gen2)))))))
+ (* 0.5 (+ (<a class=quiet href="#oscil">oscil</a> gen1)
+ (<a class=quiet href="#oscil">oscil</a> gen2))))))))
</pre>
<hr>
<div class="center"><img src="pix/t5sum.png" alt="t5"></div>
@@ -3037,16 +3036,16 @@ we can truncate its spectrum at the desired number of harmonics:
(or (and (< n 128)
(not B)
(previous-results n))
- (let* ((coeffs (make-float-vector (* 2 n) 0.0))
+ (let* ((coeffs (make-float-vector (* 2 n)))
(size (expt 2 12))
- (rl (make-float-vector size 0.0)))
+ (rl (make-float-vector size)))
(do ((incr (/ (* 2 pi) size))
(index (or B (max 1 (floor (/ n 2)))))
(i 0 (+ i 1))
(x 0.0 (+ x incr)))
((= i size))
(set! (rl i) (<em class=red>tanh</em> (* index (<em class=red>sin</em> x))))) ; make our desired square wave
- (<a class=quiet href="#spectrum">spectrum</a> rl (make-float-vector size 0.0) #f 2) ; get its spectrum
+ (<a class=quiet href="#spectrum">spectrum</a> rl (make-float-vector size) #f 2) ; get its spectrum
(do ((i 0 (+ i 1))
(j 0 (+ j 2)))
((= i n))
@@ -3086,10 +3085,8 @@ Even more amusing is this algorithm (related to tanh(sin)):
<pre class="indented">
(define (cossq c theta) ; as c -> 1.0+, more of a square wave (try 1.00001)
(let* ((cs (cos theta)) ; (+ theta pi) if matching sin case (or (- ...))
- (cp1 (+ c 1.0))
- (cm1 (- c 1.0))
- (cm1c (expt cm1 cs))
- (cp1c (expt cp1 cs)))
+ (cm1c (expt (- c 1.0) cs))
+ (cp1c (expt (+ c 1.0) cs)))
(/ (- cp1c cm1c)
(+ cp1c cm1c)))) ; from "From Squares to Circles..." Lasters and Sharpe, Math Spectrum 38:2
@@ -3355,11 +3352,7 @@ As the modulating signal approaches a spike (as n increases), the bulk of the en
(<a class=quiet href="#outa">outa</a> i (* (<a class=quiet href="#env">env</a> ampf)
(<a class=quiet href="#oscil">oscil</a> car1 (* index
(<em class=red>ncos</em> mod1))))))))
- (list
- (list 0.0 1) (list 2.0 2)
- (list 4.0 4) (list 6.0 8)
- (list 8.0 16) (list 10.0 32)
- (list 12.0 64) (list 14.0 128))))
+ '((0.0 1) (2.0 2) (4.0 4) (6.0 8) (8.0 16) (10.0 32) (12.0 64) (14.0 128))))
</pre>
<img class="indented" src="pix/ncosfm.png" alt="ncos as FM">
@@ -4541,7 +4534,7 @@ make-wave-train-with-env (defined in generators.scm) returns a new wave-train ge
<pre class="indented">
(with-sound (:play #t)
(let ((gen (make-wave-train 440.0
- :wave (let ((v (make-float-vector 64 0.0))
+ :wave (let ((v (make-float-vector 64))
(g (make-ncos 400 10)))
(set! (mus-phase g) (* -0.5 pi))
(do ((i 0 (+ i 1)))
@@ -4599,7 +4592,7 @@ lambda: ( -- )
<!--
(with-sound (:clipped #f :statistics #t :scaled-to .5 :play #t)
- (let ((gen (make-wave-train 300.0 :wave (let ((v (make-float-vector 64 0.0))
+ (let ((gen (make-wave-train 300.0 :wave (let ((v (make-float-vector 64))
(g (make-sum-of-cosines 10 400 (* -0.5 pi))))
(do ((i 0 (+ i 1)))
((= i 64))
@@ -4622,15 +4615,15 @@ Here is a FOF instrument based loosely on fof.c of Perry Cook and the article
(<a class=quiet href="sndscm.html#definstrument">definstrument</a> (fofins beg dur frq amp vib f0 a0 f1 a1 f2 a2 ve ae)
(let* ((start (<a class=quiet href="#secondstosamples">seconds->samples</a> beg))
(end (+ start (<a class=quiet href="#secondstosamples">seconds->samples</a> dur)))
- (ampf (<a class=quiet href="#make-env">make-env</a> (or ae (list 0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
+ (ampf (<a class=quiet href="#make-env">make-env</a> (or ae '(0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(frq0 (<a class=quiet href="#hztoradians">hz->radians</a> f0))
(frq1 (<a class=quiet href="#hztoradians">hz->radians</a> f1))
(frq2 (<a class=quiet href="#hztoradians">hz->radians</a> f2))
(foflen (if (= *clm-srate* 22050) 100 200))
(vibr (<a class=quiet href="#make-oscil">make-oscil</a> 6))
- (vibenv (<a class=quiet href="#make-env">make-env</a> (or ve (list 0 1 100 1)) :scaler vib :duration dur))
+ (vibenv (<a class=quiet href="#make-env">make-env</a> (or ve '(0 1 100 1)) :scaler vib :duration dur))
(win-freq (/ (* 2 pi) foflen))
- (foftab (make-float-vector foflen 0.0))
+ (foftab (make-float-vector foflen))
(wt0 (<em class=red>make-wave-train</em> :wave foftab :frequency frq)))
(do ((i 0 (+ i 1)))
((= i foflen))
@@ -5598,8 +5591,7 @@ example that puts formant on the edge of disaster (the glitch is about to explod
<pre class="indented">
(<a class=quiet href="sndscm.html#wsdoc">with-sound</a> (:channels 2)
- (let* ((dur 3)
- (samps (<a class=quiet href="#secondstosamples">seconds->samples</a> dur))
+ (let* ((samps (<a class=quiet href="#secondstosamples">seconds->samples</a> 3))
(flta (<em class=red>make-formant</em> 100 .999))
(fltc (<em class=red>make-firmant</em> 100 .999))
(vibosc (<a class=quiet href="#make-oscil">make-oscil</a> 10))
@@ -5737,7 +5729,7 @@ The Hilbert transform can be implemented with an fir-filter:
<pre class="indented">
(define* (make-hilbert-transform (len 30))
(let* ((arrlen (+ 1 (* 2 len)))
- (arr (make-float-vector arrlen 0.0))
+ (arr (make-float-vector arrlen))
(lim (if (even? len) len (+ 1 len))))
(do ((i (- len) (+ i 1)))
((= i lim))
@@ -6141,8 +6133,7 @@ delay line as the coefficients for an FIR filter:
<pre class="indented">
(<a class=quiet href="sndscm.html#definstrument">definstrument</a> (flux start-time file frequency combs0 combs1 (scaler 0.99) (comb-len 32))
(let* ((beg (<a class=quiet href="#secondstosamples">seconds->samples</a> start-time))
- (len (<a class=quiet href="extsnd.html#mussoundframples">mus-sound-framples</a> file))
- (end (+ beg len))
+ (end (+ beg (<a class=quiet href="extsnd.html#mussoundframples">mus-sound-framples</a> file)))
(num-combs0 (length combs0))
(num-combs1 (length combs1))
(cmbs0 (make-vector num-combs0))
@@ -6318,8 +6309,7 @@ old analog tapes — the reverb slightly precedes the direct signal:
(comb3 (make-comb 0.715 5399))
(comb4 (make-comb 0.697 5801))
(file-dur (mus-sound-framples file))
- (decay-dur *clm-srate*)
- (len (floor (+ decay-dur file-dur)))
+ (len (floor (+ *clm-srate* file-dur))) ; *clm-srate* = 1.0 decay dur
(rd (make-readin file)) ; the direct signal (via sound-let below)
(d (make-delay dly)) ; this delays the direct signal
(backup (min 4799 dly)))
@@ -7068,8 +7058,7 @@ one argument that return a new input sample whenever they are called by granulat
<pre class="indented">
(<a class=quiet href="sndscm.html#definstrument">definstrument</a> (granulate-sound file beg dur (orig-beg 0.0) (exp-amt 1.0))
(let* ((f-srate (srate file))
- (f-start (round (* f-srate orig-beg)))
- (f (<a class=quiet href="#make-readin">make-readin</a> file :start f-start))
+ (f (<a class=quiet href="#make-readin">make-readin</a> file :start (round (* f-srate orig-beg))))
(st (<a class=quiet href="#secondstosamples">seconds->samples</a> beg))
(new-dur (or dur (- (<a class=quiet href="extsnd.html#mussoundduration">mus-sound-duration</a> file) orig-beg)))
(exA (<em class=red>make-granulate</em> :input f :expansion exp-amt))
@@ -7518,7 +7507,7 @@ object.
;; swap channels of stereo file
(let ((input (make-file->frample "stereo.snd"))
(len (mus-sound-framples "stereo.snd"))
- (frample (make-float-vector 2 0.0)))
+ (frample (make-float-vector 2)))
(do ((i 0 (+ i 1)))
((= i len))
(file->frample input i frample)
@@ -7797,7 +7786,7 @@ use its :output argument:
</p>
<pre class="indented">
-(with-sound (<em class=red>:output</em> (make-float-vector 44100 0.0)) ; this sets *output*, the default output location
+(with-sound (<em class=red>:output</em> (make-float-vector 44100)) ; this sets *output*, the default output location
(<a class=quiet href="sndscm.html#vdoc">fm-violin</a> 0 1 440 .1))
</pre>
@@ -7825,7 +7814,7 @@ use its :output argument:
<pre class="indented">
(let ((input (<a class=quiet href="#make-readin">make-readin</a> "oboe.snd" :start 1000)))
- (with-sound ((make-float-vector 10 0.0))
+ (with-sound ((make-float-vector 10))
(do ((i 0 (+ i 1)))
((= i 10))
(<em class=red>outa</em> i (<em class=red>ina</em> i (lambda (loc chn)
@@ -7833,13 +7822,13 @@ use its :output argument:
</pre>
<pre class="indented">
-(let ((outv (make-float-vector 10 0.0)))
+(let ((outv (make-float-vector 10)))
(with-sound ()
(do ((i 0 (+ i 1)))
((= i 10))
(outa i (* i .1) (lambda (loc val chan)
(set! (outv loc) val)))))
- outv) ; this is equivalent to using :output (make-float-vector 10 0.0) as a with-sound argument
+ outv) ; this is equivalent to using :output (make-float-vector 10) as a with-sound argument
</pre>
@@ -8272,7 +8261,7 @@ of <a href="#ncosdoc">ncos and nsin</a>.
noid's phase argument can be a float-vector, <code>'min-peak</code>, <code>'max-peak</code>, or omitted (#f).
If omitted, the phases are set to random numbers between 0 and 2 pi; if
a float-vector, the float-vector's values are used as the phases; if 'max-peak, all phases are set
-to pi/2 (ncos essentially — use <code>(make-float-vector n 0.0)</code> to get nsin);
+to pi/2 (ncos essentially — use <code>(make-float-vector n)</code> to get nsin);
and if 'min-peak, the minimum peak amplitude phases in <a href="sndscm.html#peakphasesdoc">peak-phases.scm</a> are used.
In the 'min-peak and 'max-peak cases, noid's output is normalized to fall between -1.0 and 1.0.
polyoid-env is an extension of polyoid that takes envelopes to control the amplitude and phase of each
@@ -8288,7 +8277,7 @@ harmonic.
(with-sound (:clipped #f :output (string-append "test-noid-" (number->string i) ".snd"))
(let ((samps 44100)
(gen (make-noid 100.0 32 (if (= i 0) 'max-peak
- (if (= i 1) (make-float-vector 32 0.0)
+ (if (= i 1) (make-float-vector 32)
(if (= i 2) #f
'min-peak))))))
(do ((i 0 (+ i 1)))
@@ -9471,8 +9460,7 @@ safe maximum r is:
<pre class="indented">
(define (safe-rkodd-max-r freq srate)
- (let* ((topk (floor (/ srate 3 freq)))
- (k2-1 (- (* 2 topk) 1)))
+ (let ((k2-1 (- (* 2 (floor (/ srate 3 freq))) 1)))
(expt (* .001 k2-1) (/ 1.0 k2-1))))
</pre>
@@ -9614,9 +9602,8 @@ We could mimic the fft display window in the "lisp graph" via:
</p>
<pre class="indented">
-(let* ((rd (make-readin "oboe.snd"))
- (ft (<em class=red>make-moving-fft</em> rd))
- (data (make-float-vector 256 0.0)))
+(let ((ft (<em class=red>make-moving-fft</em> (make-readin "oboe.snd")))
+ (data (make-float-vector 256)))
(set! (lisp-graph?) #t)
(do ((i 0 (+ i 1)))
((= i 10000))
@@ -9727,8 +9714,7 @@ hopefully unobtrusively. Here is an example, including a stereo reverb:
(outdel12 (make-delay (seconds->samples .01)))
(file-dur (framples *reverb*))
- (decay-dur *clm-srate*)
- (len (floor (+ decay-dur file-dur))))
+ (len (floor (+ *clm-srate* file-dur))))
(do ((i 0 (+ i 1)))
((= i len))
@@ -10070,7 +10056,7 @@ We could define our own FIR filter using dot-product:
<pre class="indented">
(define (make-fr-filter coeffs)
- (list coeffs (make-float-vector (length coeffs) 0.0)))
+ (list coeffs (make-float-vector (length coeffs))))
(define (fr-filter flt x)
(let* ((coeffs (car flt))
@@ -10256,8 +10242,8 @@ only difference is that mus-fft includes the fft length as an argument, whereas
<pre class="indented">
(let* ((len (mus-sound-framples "oboe.snd"))
(fsize (expt 2 (ceiling (log len 2))))
- (rdata (make-float-vector fsize 0.0))
- (idata (make-float-vector fsize 0.0)))
+ (rdata (make-float-vector fsize))
+ (idata (make-float-vector fsize)))
(file->array "oboe.snd" 0 0 len rdata)
(<em class=red>mus-fft</em> rdata idata fsize 1)
(let ((fsize2 (/ fsize 2))
diff --git a/snddiff.scm b/snddiff.scm
index f9411b4..1acb9e2 100644
--- a/snddiff.scm
+++ b/snddiff.scm
@@ -2,11 +2,7 @@
(define (cross-correlate snd0 chn0 snd1 chn1)
- (let* ((len0 (framples snd0 chn0))
- (len1 (framples snd1 chn1))
- (ilen (max len0 len1))
- (pow2 (ceiling (log ilen 2)))
- (fftlen (floor (expt 2 pow2))))
+ (let ((fftlen (floor (expt 2 (ceiling (log (max (framples snd0 chn0) (framples snd1 chn1)) 2))))))
(correlate (channel->float-vector 0 fftlen snd1 chn1)
(channel->float-vector 0 fftlen snd0 chn0))))
@@ -14,8 +10,7 @@
;; returns the probable lagtime between the two sounds (negative means second sound is delayed)
(let* ((corr (cross-correlate snd0 chn0 snd1 chn1))
(len (length corr))
- (data (float-vector-peak-and-location corr))
- (lag (cadr data)))
+ (lag (cadr (float-vector-peak-and-location corr))))
(if (= lag -1)
0
(if (< lag (/ len 2))
@@ -96,11 +91,8 @@
(s1 (channel->float-vector 0 #f snd1 chn1)))
(or (snddiff-1 s0 s1 0.0)
(let* ((pos (maxamp-position snd0 chn0))
- (mx0 (sample pos snd0 chn0))
- (mx1 (sample pos snd1 chn1)) ; use actual values to keep possible sign difference
- (scl (/ mx1 mx0))
+ (scl (/ (sample pos snd1 chn1) (sample pos snd0 chn0))) ; use actual values to keep possible sign difference
(diff (snddiff-1 (float-vector-scale! s0 scl) s1)))
-
(if (eq? diff 'no-difference)
(list 'scale scl)
(and (list? diff)
@@ -145,11 +137,8 @@
(list 'lag lag res pre0 pre1 post0 post1)
(list res pre0 pre1 post0 post1))))
(let* ((pos (maxamp-position snd0 chn0))
- (mx0 (sample pos snd0 chn0))
- (mx1 (sample pos snd1 chn1)) ; use actual values to keep possible sign difference
- (scl (/ mx1 mx0))
+ (scl (/ (sample pos snd1 chn1) (sample pos snd0 chn0))) ; use actual values to keep possible sign difference
(diff (snddiff-1 (float-vector-scale! s0 scl) s1 0.0001)))
-
(if (eq? diff 'no-difference)
(list 'scale scl 'lag lag pre0 pre1 post0 post1)
(and (list? diff)
diff --git a/sndscm.html b/sndscm.html
index 0160245..58b839a 100644
--- a/sndscm.html
+++ b/sndscm.html
@@ -952,18 +952,17 @@ time for perfection...):
(<a class=quiet href="extsnd.html#scanchannel">scan-channel</a>
(lambda (y)
(if (not (<= -0.9999 y 0.9999))
- (if in-clip
- (set! clip-end samp)
- (begin
- (set! in-clip #t)
- (set! clip-beg samp)
- (set! clip-end samp)))
+ (begin
+ (unless in-clip
+ (set! in-clip #t)
+ (set! clip-beg samp))
+ (set! clip-end samp))
(if in-clip
(begin
(set! in-clip #f)
(set! (clip-data clip-ctr) clip-beg)
(set! (clip-data (+ 1 clip-ctr)) clip-end)
- (set! clip-max-len (max clip-max-len (+ 1 (- clip-end clip-beg))))
+ (set! clip-max-len (max clip-max-len (- (+ clip-end 1) clip-beg)))
(set! clip-ctr (+ clip-ctr 2)))))
(set! samp (+ 1 samp))
#f)) ; make sure scan doesn't quit prematurely
@@ -1003,7 +1002,7 @@ end points. (This is also "just-good-enough" software).
<pre class="indented">
(define (fix-clip clip-beg-1 clip-end-1)
(and (> clip-end-1 clip-beg-1)
- (let* ((dur (+ 1 (- clip-end-1 clip-beg-1)))
+ (let* ((dur (- (+ clip-end-1 1) clip-beg-1))
(samps (channel->float-vector (- clip-beg-1 4) (+ dur 9)))
(clip-beg 3)
(clip-end (+ dur 4)))
@@ -1527,9 +1526,10 @@ at random), and car3 and mod3 putting a sort of formant at the minor third
<pre class="indented">
(<a class=quiet href="#wsdoc">with-sound</a> ()
- (let ((fbell '(0 1 2 1.1000 25 .7500 75 .5000 100 .5000))
- (abell '(0 0 .1000 1 10 .6000 25 .3000 50 .1500 90 .1000 100 0)))
- (fm-bell 0.0 2.0 220.0 .5 abell fbell 0.5)))
+ (fm-bell 0.0 2.0 220.0 .5
+ '(0 0 .1000 1 10 .6000 25 .3000 50 .1500 90 .1000 100 0)
+ '(0 1 2 1.1000 25 .7500 75 .5000 100 .5000)
+ 0.5))
</pre>
<div class="separator"></div>
@@ -2937,7 +2937,7 @@ lambda: <{ x }> pi random ; #f #f rotate-phase \ randomizes phases
</p>
<pre class="indented">
-> (define d0 (make-float-vector 8 0.0))
+> (define d0 (make-float-vector 8))
d0
;; and similarly for d1 and d2 ...
> (set! (d0 2) 1.0)
@@ -3695,13 +3695,13 @@ then
<pre class="indented">
(let* ((size 128)
- (x0 (make-float-vector size 0.0))
- (x1 (make-float-vector size 0.0))
- (x2 (make-float-vector size 0.0)))
+ (x0 (make-float-vector size))
+ (x1 (make-float-vector size))
+ (x2 (make-float-vector size)))
(do ((i 0 (+ i 1)))
((= i 12))
(let ((val (sin (/ (* 2 pi i) 12.0))))
- (set! (x1 (+ i (- (/ size 4) 6))) val)))
+ (set! (x1 (- (+ i (/ size 4)) 6)) val)))
(do ((i 0 (+ i 1)))
((= i 1024))
(<em class=red>compute-uniform-circular-string</em> size x0 x1 x2 1.0 0.1 0.0)
@@ -7173,35 +7173,6 @@ the clef instead.
</p>
<img class="indented" src="pix/sndcmn.png" alt="Snd with music symbols">
-<p>This was created with:
-</p>
-
-<pre class="indented">
-(<a class=quiet href="#wsdoc">with-sound</a> () (fm-violin 0 1 440 .1))
-
-(define (draw-staff x0 y0 width line-sep)
- (let ((cr (make-cairo (car (channel-widgets 0 0)))))
- (do ((line 0 (+ 1 line))
- (x x0)
- (y y0 (+ y line-sep)))
- ((= line 5))
- (<a class=quiet href="extsnd.html#drawline">draw-line</a> x y (+ x width) y 0 0 time-graph cr))
- (free-cairo cr)))
-
-(define (draw-a-440 x0 y0 size)
- (let ((width (* size 100))
- (line-sep (* size 20))
- (qsize (* size 80)))
- (draw-staff (+ x0 (* size 5)) y0 width line-sep)
- (draw-treble-clef x0 (+ y0 (* size 61)) qsize)
- (draw-quarter-note (+ x0 (* 70 size)) (+ y0 (* size 52)) qsize)
- (let ((cr (make-cairo (car (channel-widgets 0 0)))))
- (<a class=quiet href="extsnd.html#fillrectangle">fill-rectangle</a> (+ x0 (* 90 size)) (- y0 (* size 10)) (* size 3) (* size 60) 0 0 time-graph #f cr)
- (free-cairo cr))))
-
-(draw-a-440 50 80 1.0)
-</pre>
-
<p>
A fancier <a href="extsnd.html#waltzexample">example</a> is included in musglyphs.scm. It takes a list of notes, each mixed as a virtual mix,
and displays the note pitches as music notation on two staves at the top of the graph. The two main
@@ -8215,7 +8186,7 @@ to a good candidate, but that seems like asking for trouble.
(close-sound old)))
(let ((ns (new-sound "test.snd" :channels 5))
- (data (make-float-vector dur 0.0)))
+ (data (make-float-vector dur)))
(let ((phases (make-vector 8 0.0))
(correct 6.1442))
@@ -8227,8 +8198,8 @@ to a good candidate, but that seems like asking for trouble.
((> n 512))
(let* ((size (expt 2 (ceiling (/ (log (* 8 n)) (log 2)))))
- (fft-rl (make-float-vector size 0.0))
- (fft-im (make-float-vector size 0.0))
+ (fft-rl (make-float-vector size))
+ (fft-im (make-float-vector size))
(pi2 (/ pi 2)))
(do ((m 0 (+ m 1)))
@@ -8321,8 +8292,8 @@ minimum, maximum, and average peaks. The graph is logarithmic (that is we show
(define (get-peak choice n cur-phases)
(let* ((fft-mult 128)
(size (get-fft-size choice n fft-mult))
- (fft-rl (make-float-vector size 0.0))
- (fft-im (make-float-vector size 0.0))
+ (fft-rl (make-float-vector size))
+ (fft-im (make-float-vector size))
(nc (if (eq? choice :all) 0
(if (eq? choice :odd) 1
(if (eq? choice :even) 2 3)))))
@@ -8535,7 +8506,7 @@ Here is the GA code used to find the initial-phase polynomials mentioned above:
(f2 (random 1.0)))
(do ((k 0 (+ k 1)))
((= k n))
- (set! (phases k) (modulo (/ (+ (* f2 k k) (* f1 k)) pi) 2.0)))
+ (set! (phases k) (modulo (/ (* k (+ (* f2 k) f1)) pi) 2.0)))
(set! (pop i) (list (get-peak choice n phases) f1 f2))))
;; now do the GA search with annealing
(do ((try 0 (+ try 1))
@@ -8550,7 +8521,7 @@ Here is the GA code used to find the initial-phase polynomials mentioned above:
(f2 (+ (list-ref (pop i) 2) (random increment))))
(do ((k 0 (+ k 1)))
((= k n))
- (set! (phases k) (modulo (/ (+ (* f2 k k) (* f1 k)) pi) 2.0)))
+ (set! (phases k) (modulo (/ (* k (+ (* f2 k) f1)) pi) 2.0)))
(set! (pop j) (list (get-peak choice n phases) f1 f2)))))))
</pre>
@@ -8752,81 +8723,81 @@ of harmonics, then the minimum peak amplitude, then (log peak n).
38 6.056 0.4951 | 42 6.403 0.4968 | 95 10.275 0.5116 | 27 6.134 0.5503
69 8.140 0.4952 | 74 8.488 0.4969 | 82 9.531 0.5116 | 41 7.720 0.5504
49 6.872 0.4952 | 78 8.715 0.4970 | 118 11.484 0.5117 | 36 7.188 0.5504
-58 7.471 0.4953 | 37 6.019 0.4971 | 110 11.084 0.5117 | 16 4.600 0.5504
-82 8.870 0.4953 | 46 6.709 0.4972 | 91 10.063 0.5118 | 108 13.162 0.5505
-48 6.804 0.4953 | 39 6.182 0.4972 | 86 9.779 0.5119 | 122 14.078 0.5505
-81 8.821 0.4954 | 105 10.116 0.4972 | 107 10.937 0.5119 | 43 7.936 0.5507
-103 9.936 0.4954 | 47 6.785 0.4973 | 92 10.124 0.5119 | 54 8.998 0.5508
-64 7.850 0.4955 | 38 6.108 0.4975 | 90 10.013 0.5120 | 52 8.817 0.5509
-56 7.349 0.4955 | 89 9.332 0.4976 | 71 8.877 0.5122 | 66 10.066 0.5512
-42 6.374 0.4956 | 111 10.417 0.4976 | 79 9.381 0.5123 | 70 10.403 0.5513
-63 7.793 0.4956 | 40 6.272 0.4978 | 75 9.137 0.5124 | 106 13.080 0.5513
-73 8.384 0.4956 | 56 7.419 0.4979 | 98 10.481 0.5124 | 45 8.157 0.5514
+73 8.372 0.4952 | 37 6.019 0.4971 | 110 11.084 0.5117 | 16 4.600 0.5504
+58 7.471 0.4953 | 46 6.709 0.4972 | 91 10.063 0.5118 | 108 13.162 0.5505
+82 8.870 0.4953 | 39 6.182 0.4972 | 86 9.779 0.5119 | 122 14.078 0.5505
+48 6.804 0.4953 | 105 10.116 0.4972 | 107 10.937 0.5119 | 43 7.936 0.5507
+81 8.821 0.4954 | 47 6.785 0.4973 | 92 10.124 0.5119 | 54 8.998 0.5508
+103 9.936 0.4954 | 38 6.108 0.4975 | 90 10.013 0.5120 | 52 8.817 0.5509
+64 7.850 0.4955 | 89 9.332 0.4976 | 71 8.877 0.5122 | 66 10.066 0.5512
+56 7.349 0.4955 | 111 10.417 0.4976 | 79 9.381 0.5123 | 70 10.403 0.5513
+42 6.374 0.4956 | 40 6.272 0.4978 | 75 9.137 0.5124 | 106 13.080 0.5513
+63 7.793 0.4956 | 56 7.419 0.4979 | 98 10.481 0.5124 | 45 8.157 0.5514
40 6.224 0.4956 | 106 10.198 0.4980 | 78 9.336 0.5127 | 62 9.734 0.5514
83 8.939 0.4957 | 59 7.618 0.4980 | 87 9.875 0.5128 | 12 3.936 0.5514
67 8.044 0.4959 | 57 7.489 0.4980 | 512 24.510 0.5128 | 34 6.991 0.5515
76 8.567 0.4960 | 91 9.457 0.4981 | 77 9.278 0.5128 | 85 11.589 0.5515
85 9.056 0.4960 | 51 7.088 0.4981 | 89 9.998 0.5129 | 125 14.336 0.5515
92 9.420 0.4960 | 80 8.870 0.4981 | 81 9.529 0.5130 | 88 11.815 0.5515
-55 7.300 0.4961 | 81 8.926 0.4981 | 70 8.849 0.5132 | 64 9.912 0.5515
-53 7.168 0.4961 | 101 9.965 0.4982 | 61 8.247 0.5132 | 46 8.261 0.5515
-105 10.064 0.4961 | 119 10.815 0.4982 | 72 8.986 0.5134 | 72 10.580 0.5516
-52 7.102 0.4961 | 77 8.707 0.4982 | 80 9.493 0.5136 | 92 12.112 0.5516
-104 10.017 0.4962 | 76 8.651 0.4982 | 73 9.061 0.5137 | 60 9.568 0.5516
-50 6.966 0.4962 | 62 7.817 0.4982 | 74 9.134 0.5139 | 124 14.280 0.5516
-65 7.935 0.4962 | 55 7.364 0.4982 | 63 8.414 0.5141 | 103 12.892 0.5516
-71 8.291 0.4962 | 67 8.128 0.4983 | 68 8.755 0.5142 | 123 14.218 0.5516
-47 6.757 0.4962 | 110 10.408 0.4984 | 57 7.998 0.5143 | 56 9.213 0.5517
-45 6.613 0.4962 | 90 9.422 0.4985 | 76 9.274 0.5143 | 98 12.555 0.5518
-100 9.828 0.4962 | 60 7.700 0.4985 | 64 8.501 0.5146 | 48 8.469 0.5519
-44 6.544 0.4964 | 86 9.213 0.4985 | 67 8.715 0.5149 | 128 14.551 0.5519
-57 7.441 0.4964 | 108 10.325 0.4986 | 58 8.103 0.5153 | 120 14.042 0.5519
-46 6.691 0.4965 | 44 6.599 0.4986 | 2048 50.887 0.5154 | 116 13.783 0.5519
-54 7.246 0.4965 | 88 9.324 0.4986 | 62 8.391 0.5154 | 110 13.386 0.5519
-84 9.023 0.4965 | 64 7.957 0.4987 | 69 8.870 0.5155 | 32 6.772 0.5519
-94 9.544 0.4965 | 83 9.061 0.4988 | 65 8.610 0.5157 | 84 11.537 0.5519
-95 9.595 0.4966 | 68 8.204 0.4988 | 66 8.679 0.5158 | 42 7.870 0.5520
-43 6.475 0.4966 | 102 10.046 0.4988 | 53 7.750 0.5158 | 76 10.919 0.5520
-74 8.479 0.4966 | 85 9.173 0.4989 | 59 8.195 0.5159 | 104 12.987 0.5521
-66 8.012 0.4967 | 114 10.621 0.4989 | 51 7.602 0.5159 | 61 9.674 0.5521
-68 8.131 0.4967 | 61 7.775 0.4989 | 55 7.908 0.5160 | 105 13.058 0.5521
-114 10.518 0.4968 | 125 11.122 0.4989 | 44 7.048 0.5160 | 53 8.953 0.5521
-91 9.407 0.4969 | 70 8.328 0.4989 | 47 7.293 0.5160 | 75 10.845 0.5521
-87 9.201 0.4969 | 36 5.978 0.4990 | 38 6.537 0.5161 | 115 13.732 0.5521
-88 9.256 0.4970 | 98 9.853 0.4990 | 54 7.845 0.5164 | 71 10.523 0.5521
-75 8.550 0.4970 | 63 7.904 0.4990 | 60 8.297 0.5168 | 81 11.319 0.5522
-98 9.767 0.4971 | 107 10.296 0.4990 | 50 7.554 0.5169 | 100 12.717 0.5522
-86 9.154 0.4971 | 103 10.102 0.4990 | 56 8.011 0.5169 | 73 10.689 0.5522
-80 8.832 0.4971 | 118 10.812 0.4990 | 52 7.716 0.5171 | 107 13.202 0.5522
-78 8.722 0.4971 | 115 10.674 0.4990 | 48 7.407 0.5173 | 50 8.676 0.5523
-61 7.718 0.4971 | 58 7.586 0.4990 | 45 7.165 0.5173 | 80 11.248 0.5523
-90 9.369 0.4972 | 128 11.261 0.4990 | 40 6.748 0.5176 | 113 13.613 0.5523
-101 9.925 0.4973 | 53 7.253 0.4990 | 46 7.276 0.5184 | 55 9.146 0.5523
-99 9.827 0.4973 | 94 9.654 0.4991 | 42 6.941 0.5184 | 49 8.583 0.5524
-72 8.392 0.4974 | 69 8.275 0.4991 | 34 6.223 0.5184 | 111 13.484 0.5524
-97 9.734 0.4974 | 92 9.553 0.4991 | 39 6.683 0.5185 | 91 12.084 0.5524
-79 8.789 0.4974 | 120 10.909 0.4991 | 49 7.532 0.5188 | 121 14.145 0.5524
-109 10.316 0.4974 | 113 10.586 0.4991 | 41 6.881 0.5194 | 79 11.178 0.5525
-62 7.792 0.4975 | 96 9.759 0.4991 | 36 6.432 0.5194 | 69 10.373 0.5525
-89 9.329 0.4975 | 66 8.095 0.4992 | 43 7.055 0.5195 | 119 14.019 0.5525
-112 10.460 0.4975 | 73 8.515 0.4992 | 37 6.533 0.5198 | 117 13.889 0.5525
-106 10.180 0.4976 | 84 9.133 0.4992 | 32 6.061 0.5199 | 118 13.956 0.5525
-96 9.699 0.4978 | 116 10.733 0.4993 | 33 6.163 0.5201 | 112 13.561 0.5525
-102 10.000 0.4979 | 100 9.968 0.4993 | 29 5.766 0.5203 | 127 14.536 0.5525
-77 8.694 0.4979 | 54 7.328 0.4993 | 35 6.362 0.5205 | 78 11.104 0.5526
-116 10.667 0.4980 | 95 9.717 0.4993 | 26 5.452 0.5206 | 68 10.294 0.5526
-115 10.622 0.4980 | 121 10.965 0.4993 | 31 5.988 0.5212 | 58 9.429 0.5526
-113 10.533 0.4981 | 122 11.011 0.4993 | 24 5.253 0.5220 | 15 4.466 0.5526
-128 11.210 0.4981 | 117 10.783 0.4994 | 30 5.907 0.5222 | 65 10.042 0.5526
-111 10.443 0.4981 | 104 10.169 0.4994 | 23 5.148 0.5226 | 99 12.671 0.5526
-122 10.950 0.4982 | 79 8.865 0.4994 | 21 4.920 0.5233 | 83 11.495 0.5526
-127 11.176 0.4983 | 65 8.042 0.4994 | 27 5.620 0.5238 | 126 14.478 0.5526
-108 10.313 0.4984 | 71 8.407 0.4995 | 28 5.732 0.5240 | 90 12.023 0.5526
-117 10.740 0.4985 | 109 10.414 0.4995 | 25 5.403 0.5241 | 44 8.096 0.5527
-126 11.145 0.4985 | 99 9.928 0.4995 | 22 5.055 0.5242 | 26 6.057 0.5528
-107 10.273 0.4985 | 49 6.989 0.4996 | 18 4.569 0.5257 | 82 11.463 0.5535
-120 10.878 0.4985 | 97 9.832 0.4996 | 20 4.839 0.5264 | 35 7.164 0.5538
-110 10.417 0.4985 | 93 9.629 0.4997 | 17 4.463 0.5280 | 67 10.270 0.5540
+75 8.512 0.4960 | 81 8.926 0.4981 | 70 8.849 0.5132 | 64 9.912 0.5515
+55 7.300 0.4961 | 101 9.965 0.4982 | 61 8.247 0.5132 | 46 8.261 0.5515
+53 7.168 0.4961 | 119 10.815 0.4982 | 72 8.986 0.5134 | 72 10.580 0.5516
+105 10.064 0.4961 | 77 8.707 0.4982 | 80 9.493 0.5136 | 92 12.112 0.5516
+52 7.102 0.4961 | 76 8.651 0.4982 | 73 9.061 0.5137 | 60 9.568 0.5516
+104 10.017 0.4962 | 62 7.817 0.4982 | 74 9.134 0.5139 | 124 14.280 0.5516
+50 6.966 0.4962 | 55 7.364 0.4982 | 63 8.414 0.5141 | 103 12.892 0.5516
+65 7.935 0.4962 | 67 8.128 0.4983 | 68 8.755 0.5142 | 123 14.218 0.5516
+71 8.291 0.4962 | 110 10.408 0.4984 | 57 7.998 0.5143 | 56 9.213 0.5517
+47 6.757 0.4962 | 90 9.422 0.4985 | 76 9.274 0.5143 | 98 12.555 0.5518
+45 6.613 0.4962 | 60 7.700 0.4985 | 64 8.501 0.5146 | 48 8.469 0.5519
+100 9.828 0.4962 | 86 9.213 0.4985 | 67 8.715 0.5149 | 128 14.551 0.5519
+74 8.468 0.4964 | 108 10.325 0.4986 | 58 8.103 0.5153 | 120 14.042 0.5519
+44 6.544 0.4964 | 44 6.599 0.4986 | 2048 50.887 0.5154 | 116 13.783 0.5519
+57 7.441 0.4964 | 88 9.324 0.4986 | 62 8.391 0.5154 | 110 13.386 0.5519
+46 6.691 0.4965 | 64 7.957 0.4987 | 69 8.870 0.5155 | 32 6.772 0.5519
+54 7.246 0.4965 | 83 9.061 0.4988 | 65 8.610 0.5157 | 84 11.537 0.5519
+84 9.023 0.4965 | 68 8.204 0.4988 | 66 8.679 0.5158 | 42 7.870 0.5520
+94 9.544 0.4965 | 102 10.046 0.4988 | 53 7.750 0.5158 | 76 10.919 0.5520
+95 9.595 0.4966 | 85 9.173 0.4989 | 59 8.195 0.5159 | 104 12.987 0.5521
+43 6.475 0.4966 | 114 10.621 0.4989 | 51 7.602 0.5159 | 61 9.674 0.5521
+66 8.012 0.4967 | 61 7.775 0.4989 | 55 7.908 0.5160 | 105 13.058 0.5521
+68 8.131 0.4967 | 125 11.122 0.4989 | 44 7.048 0.5160 | 53 8.953 0.5521
+72 8.368 0.4967 | 70 8.328 0.4989 | 47 7.293 0.5160 | 75 10.845 0.5521
+114 10.518 0.4968 | 36 5.978 0.4990 | 38 6.537 0.5161 | 115 13.732 0.5521
+77 8.656 0.4969 | 98 9.853 0.4990 | 54 7.845 0.5164 | 71 10.523 0.5521
+79 8.767 0.4969 | 63 7.904 0.4990 | 60 8.297 0.5168 | 81 11.319 0.5522
+91 9.407 0.4969 | 107 10.296 0.4990 | 50 7.554 0.5169 | 100 12.717 0.5522
+78 8.713 0.4969 | 103 10.102 0.4990 | 56 8.011 0.5169 | 73 10.689 0.5522
+87 9.201 0.4969 | 118 10.812 0.4990 | 52 7.716 0.5171 | 107 13.202 0.5522
+88 9.256 0.4970 | 115 10.674 0.4990 | 48 7.407 0.5173 | 50 8.676 0.5523
+98 9.767 0.4971 | 58 7.586 0.4990 | 45 7.165 0.5173 | 80 11.248 0.5523
+86 9.154 0.4971 | 128 11.261 0.4990 | 40 6.748 0.5176 | 113 13.613 0.5523
+80 8.832 0.4971 | 53 7.253 0.4990 | 46 7.276 0.5184 | 55 9.146 0.5523
+61 7.718 0.4971 | 94 9.654 0.4991 | 42 6.941 0.5184 | 49 8.583 0.5524
+101 9.922 0.4972 | 69 8.275 0.4991 | 34 6.223 0.5184 | 111 13.484 0.5524
+90 9.369 0.4972 | 92 9.553 0.4991 | 39 6.683 0.5185 | 91 12.084 0.5524
+89 9.320 0.4973 | 120 10.909 0.4991 | 49 7.532 0.5188 | 121 14.145 0.5524
+99 9.827 0.4973 | 113 10.586 0.4991 | 41 6.881 0.5194 | 79 11.178 0.5525
+97 9.734 0.4974 | 96 9.759 0.4991 | 36 6.432 0.5194 | 69 10.373 0.5525
+109 10.316 0.4974 | 66 8.095 0.4992 | 43 7.055 0.5195 | 119 14.019 0.5525
+62 7.792 0.4975 | 73 8.515 0.4992 | 37 6.533 0.5198 | 117 13.889 0.5525
+112 10.460 0.4975 | 84 9.133 0.4992 | 32 6.061 0.5199 | 118 13.956 0.5525
+106 10.180 0.4976 | 116 10.733 0.4993 | 33 6.163 0.5201 | 112 13.561 0.5525
+96 9.699 0.4978 | 100 9.968 0.4993 | 29 5.766 0.5203 | 127 14.536 0.5525
+102 10.000 0.4979 | 54 7.328 0.4993 | 35 6.362 0.5205 | 78 11.104 0.5526
+110 10.385 0.4979 | 95 9.717 0.4993 | 26 5.452 0.5206 | 68 10.294 0.5526
+116 10.667 0.4980 | 121 10.965 0.4993 | 31 5.988 0.5212 | 58 9.429 0.5526
+115 10.622 0.4980 | 122 11.011 0.4993 | 24 5.253 0.5220 | 15 4.466 0.5526
+113 10.533 0.4981 | 117 10.783 0.4994 | 30 5.907 0.5222 | 65 10.042 0.5526
+128 11.210 0.4981 | 104 10.169 0.4994 | 23 5.148 0.5226 | 99 12.671 0.5526
+111 10.443 0.4981 | 79 8.865 0.4994 | 21 4.920 0.5233 | 83 11.495 0.5526
+122 10.950 0.4982 | 65 8.042 0.4994 | 27 5.620 0.5238 | 126 14.478 0.5526
+107 10.259 0.4982 | 71 8.407 0.4995 | 28 5.732 0.5240 | 90 12.023 0.5526
+127 11.176 0.4983 | 109 10.414 0.4995 | 25 5.403 0.5241 | 44 8.096 0.5527
+108 10.313 0.4984 | 99 9.928 0.4995 | 22 5.055 0.5242 | 26 6.057 0.5528
+117 10.740 0.4985 | 49 6.989 0.4996 | 18 4.569 0.5257 | 82 11.463 0.5535
+126 11.145 0.4985 | 97 9.832 0.4996 | 20 4.839 0.5264 | 35 7.164 0.5538
+120 10.878 0.4985 | 93 9.629 0.4997 | 17 4.463 0.5280 | 67 10.270 0.5540
121 10.925 0.4986 | 75 8.650 0.4997 | 16 4.325 0.5282 | 11 3.778 0.5544
118 10.790 0.4986 | 124 11.120 0.4997 | 19 4.741 0.5286 | 9 3.382 0.5546
124 11.060 0.4986 | 87 9.317 0.4998 | 15 4.192 0.5292 | 14 4.324 0.5548
@@ -8868,8 +8839,8 @@ of the genetic algorithm):
<pre class="indented">
-(let* ((all (cadr (get-best :all (- n 1)))) ; get the best all-harmonic phases for n - 1
- (new-phases (make-vector n 0.0))) ; place in new phase vector shifted up
+(let ((all (cadr (get-best :all (- n 1)))) ; get the best all-harmonic phases for n - 1
+ (new-phases (make-vector n 0.0))) ; place in new phase vector shifted up
(do ((k 0 (+ k 1)))
((= k (- n 1)))
(set! (new-phases (+ k 1)) (all k)))
@@ -11955,7 +11926,7 @@ an upward ramp and a downward ramp, then zips them together:
<pre class="indented">
(define (ramp-test)
- (let ((data (make-float-vector 10000 0.0)))
+ (let ((data (make-float-vector 10000)))
(<a class=quiet href="extsnd.html#newsound">new-sound</a> "new-0.snd")
(do ((i 0 (+ i 1))) ((= i 10000))
(set! (data i) (* i .0001)))
diff --git a/sndwarp.scm b/sndwarp.scm
index adcf132..bb0e786 100644
--- a/sndwarp.scm
+++ b/sndwarp.scm
@@ -155,7 +155,6 @@
(fsr (mus-sound-srate file))
;; (fsize (framples file))
(fdur (mus-sound-duration file))
- (rev-val rev)
(loc-env (clmsw-envelope-or-number loc))
(srate-env (clmsw-envelope-or-number srate))
(time-env (clmsw-envelope-or-number stretch))
@@ -281,7 +280,7 @@
(if stereo-o
(begin
(outb i outb-val)
- (if *reverb* (outa i (* rev-val outa-val) *reverb*)))))))
+ (if *reverb* (outa i (* rev outa-val) *reverb*)))))))
(if (and (not eow-flag) ;; For first section, have to backup readstart
(= section 0)
(> overlap 0)
diff --git a/spectr.scm b/spectr.scm
index 9659a28..7db9321 100644
--- a/spectr.scm
+++ b/spectr.scm
@@ -7,3137 +7,3075 @@
(provide 'snd-spectr.scm)
(define *spectr*
- (let ()
-
-;;; bass clarinet?
-(define bc-c2 '( 1.00 .0370 1.98 .0037 2.99 .0862 3.98 .0011 4.97 .0270 5.98 .0030 6.97 .0586
- 7.95 .0031 8.96 .0363 9.95 .0076 10.93 .0310 11.95 .0097 12.93 .0206 13.92 .0045 14.93 .0044
- 15.91 .0021 16.90 .0220 17.91 .0082 18.90 .0227 19.88 .0049 20.90 .0090 21.87 .0004 22.87 .0051
- 23.88 .0010 24.86 .0072 25.85 .0026 26.86 .0044 27.84 .0035 28.85 .0031 29.84 .0025 30.83 .0042
- 31.84 .0024 32.83 .0022 33.81 .0021 34.82 .0011 35.81 .0008 36.79 .0013 37.80 .0024 38.78 .0028
- 39.78 .0016 40.79 .0024 41.77 .0005 42.76 .0005 43.77 .0003 44.76 .0002 45.74 .0005 46.75 .0003
- 47.74 .0006 48.73 .0003 49.74 .0009 50.72 .0002 51.71 .0007 52.72 .0004 53.70 .0005 54.70 .0004
- 55.71 .0005 56.69 .0002 57.68 .0003 58.69 .0002 59.68 .0002 60.68 .0003 61.68 .0002 62.66 .0002
- 63.66 .0002 65.65 .0001 67.64 .0002 69.63 .0002 70.63 .0002 71.60 .0002 72.62 .0002 73.60 .0002
- 75.59 .0002 76.59 .0002 77.58 .0001 78.59 .0001 79.57 .0002 80.57 .0002 81.57 .0002 82.54 .0001
- 83.56 .0002 84.54 .0001 85.53 .0001 87.53 .0002 89.53 .0002))
-
-(define bc-cs2 '( 1.02 .0306 2.00 .0016 2.99 .0926 4.00 .0027 5.01 .0305 5.99 .0006 6.99 .0158
- 8.00 .0025 9.01 .0072 10.01 .0057 10.99 .0203 12.00 .0078 13.01 .0147 14.02 .0036 15.00 .0103
- 16.07 .0007 17.01 .0070 18.01 .0053 19.00 .0049 20.02 .0027 21.01 .0024 22.01 .0014 23.00 .0011
- 24.02 .0023 25.00 .0031 26.01 .0021 27.00 .0029 28.02 .0010 29.02 .0026 30.04 .0011 31.00 .0019
- 32.01 .0010 33.03 .0004 34.02 .0002 36.02 .0004 37.05 .0002 38.04 .0004 39.00 .0003 40.02 .0002
- 41.01 .0002 42.01 .0002 43.00 .0001 44.02 .0001 45.01 .0002 47.01 .0002 48.03 .0001 49.00 .0002
- 50.03 .0001 51.02 .0001 55.00 .0001 56.99 .0002 73.98 .0001 75.02 .0001 75.98 .0001))
-
-(define bc-d2 '( 1.01 .1419 1.97 .0009 3.00 .0865 4.01 .0008 5.00 .0059 6.00 .0009 7.00 .0110
- 8.00 .0014 9.00 .0050 10.00 .0057 11.01 .0267 12.01 .0091 13.00 .0238 14.02 .0023 15.01 .0069
- 16.01 .0033 17.00 .0064 18.01 .0036 18.99 .0067 20.01 .0026 21.01 .0047 22.01 .0037 22.99 .0040
- 24.00 .0038 25.01 .0036 26.01 .0032 27.00 .0036 27.99 .0019 29.00 .0034 30.00 .0014 31.00 .0007
- 31.98 .0003 33.04 .0002 34.05 .0003 35.04 .0003 35.95 .0002 37.05 .0003 37.98 .0002 39.07 .0002
- 40.02 .0002 40.95 .0001 42.01 .0003 42.98 .0002 44.02 .0004 44.99 .0002 46.03 .0002 46.98 .0002
- 48.04 .0001 49.01 .0001 51.02 .0002 52.03 .0002 53.01 .0002 54.01 .0001 55.01 .0002 56.02 .0001
- 65.00 .0002 66.99 .0001 69.01 .0001 71.00 .0002 73.00 .0001 74.99 .0001))
-
-(define bc-ds2 '( 1.01 .2718 2.01 .0016 3.01 .0476 4.01 .0022 5.01 .0228 6.00 .0005 7.01 .0466
- 8.01 .0014 9.00 .0179 10.01 .0059 11.00 .0254 12.01 .0099 13.00 .0176 14.01 .0031 15.02 .0109
- 16.00 .0007 17.02 .0090 18.03 .0038 19.02 .0036 20.02 .0029 21.02 .0045 22.02 .0026 23.02 .0060
- 24.02 .0031 25.02 .0023 26.02 .0033 27.02 .0041 28.02 .0033 29.02 .0034 30.03 .0007 31.04 .0005
- 32.03 .0005 33.05 .0005 34.03 .0006 35.05 .0002 36.04 .0004 37.03 .0002 38.03 .0003 39.03 .0004
- 40.03 .0002 41.03 .0004 42.03 .0003 43.03 .0006 44.04 .0002 45.05 .0005 46.04 .0001 47.05 .0003
- 48.04 .0002 49.05 .0003 50.04 .0001 51.04 .0003 52.04 .0002 53.04 .0001 55.04 .0002 57.05 .0002
- 59.06 .0002 61.07 .0002 62.06 .0001 63.06 .0002 64.05 .0001 65.06 .0001 66.06 .0002 67.06 .0002
- 68.06 .0002 70.06 .0002 72.06 .0001 74.08 .0001))
-
-(define bc-e2 '( 1.01 .1365 2.01 .0009 3.03 .0219 3.99 .0004 5.04 .0239 6.03 .0013 7.02 .0284
- 8.04 .0029 9.03 .0167 10.06 .0042 11.05 .0059 12.03 .0012 13.07 .0095 14.07 .0013 15.08 .0109
- 16.06 .0038 17.06 .0042 18.09 .0006 19.07 .0034 20.10 .0036 21.09 .0018 22.08 .0025 23.11 .0054
- 24.08 .0008 25.12 .0035 26.09 .0013 27.13 .0022 28.13 .0009 29.12 .0006 30.14 .0004 31.13 .0005
- 32.15 .0003 33.15 .0003 35.15 .0002 36.13 .0001 37.17 .0003 38.19 .0002 39.16 .0006 40.21 .0001
- 41.17 .0005 42.18 .0002 43.19 .0003 44.18 .0001 45.21 .0002 46.19 .0002 47.22 .0004 48.22 .0002
- 49.20 .0002 50.23 .0001 55.24 .0001 56.23 .0001 57.26 .0002 59.26 .0001 61.25 .0002 62.29 .0002
- 64.27 .0001))
-
-(define bc-f2 '( .99 .1014 2.00 .0021 3.02 .0301 4.02 .0012 5.00 .0893 6.02 .0028 7.03 .0333
- 8.04 .0046 9.05 .0109 10.03 .0033 11.03 .0174 12.05 .0075 13.06 .0085 14.06 .0037 15.04 .0133
- 16.08 .0021 17.07 .0017 18.07 .0009 19.05 .0015 20.07 .0002 21.08 .0068 22.09 .0033 23.10 .0060
- 24.07 .0031 25.08 .0036 26.10 .0009 27.11 .0001 28.11 .0010 29.10 .0007 30.10 .0004 31.12 .0005
- 32.13 .0002 33.11 .0005 34.11 .0003 35.12 .0004 36.13 .0002 37.14 .0005 38.12 .0001 39.14 .0005
- 40.14 .0002 41.16 .0002 43.14 .0003 45.17 .0004 46.18 .0002 47.16 .0002 49.18 .0002 51.18 .0001
- 53.19 .0002 55.22 .0001 56.19 .0002 57.21 .0001 58.22 .0002 60.23 .0002 62.22 .0001))
-
-(define bc-fs2 '( 1.01 .0724 2.02 .0045 3.01 .0626 4.01 .0014 5.00 .1104 6.00 .0041 7.00 .0216
- 8.03 .0017 9.03 .0255 10.02 .0011 11.02 .0152 12.02 .0019 13.01 .0061 14.02 .0018 15.04 .0077
- 16.05 .0009 17.04 .0031 18.04 .0014 19.02 .0058 20.04 .0005 21.03 .0030 22.03 .0030 23.05 .0048
- 24.06 .0013 25.04 .0009 26.04 .0002 27.03 .0008 28.05 .0005 29.05 .0003 30.06 .0002 31.06 .0004
- 32.05 .0005 33.05 .0003 34.04 .0002 35.05 .0004 37.08 .0006 38.06 .0002 39.07 .0003 41.06 .0003
- 42.07 .0001 43.07 .0003 44.09 .0002 45.10 .0001 47.07 .0001 51.10 .0002 53.10 .0002 54.10 .0001
- 56.09 .0002 57.09 .0001 58.12 .0001 62.11 .0001 64.11 .0001))
-
-(define bc-g2 '( 1.00 .0567 1.99 .0037 3.00 .1114 3.98 .0030 4.99 .1112 5.98 .0041 6.99 .0195
- 7.99 .0061 8.98 .0081 9.97 .0084 10.98 .0139 11.98 .0038 12.98 .0092 13.97 .0038 14.97 .0042
- 15.97 .0003 16.97 .0012 17.96 .0019 18.97 .0040 19.95 .0032 20.97 .0088 21.95 .0022 22.96 .0025
- 23.94 .0004 24.94 .0003 25.92 .0005 26.95 .0005 27.91 .0003 28.95 .0003 29.90 .0002 30.94 .0006
- 31.89 .0001 32.93 .0007 34.92 .0005 35.89 .0002 36.92 .0003 37.89 .0001 38.91 .0002 39.88 .0002
- 40.90 .0004 41.88 .0002 43.88 .0002 50.90 .0001 51.89 .0002 52.93 .0001 53.89 .0003 55.87 .0002))
-
-(define bc-gs2 '( .99 .0794 2.00 .0021 3.00 .1294 3.98 .0015 4.98 .0849 5.98 .0058 6.99 .0389
- 7.97 .0113 8.97 .0154 9.98 .0026 10.98 .0172 11.95 .0048 12.95 .0099 13.98 .0011 14.97 .0029
- 15.95 .0013 16.95 .0055 17.97 .0014 18.96 .0052 19.94 .0040 20.94 .0038 21.96 .0006 22.94 .0003
- 23.92 .0005 24.93 .0005 25.93 .0002 26.94 .0006 27.92 .0003 28.91 .0007 29.91 .0004 30.93 .0006
- 31.90 .0003 32.90 .0006 33.90 .0003 34.91 .0004 35.89 .0001 36.89 .0003 37.90 .0003 38.90 .0003
- 40.88 .0002 42.89 .0001 45.89 .0002 47.87 .0001 49.87 .0003 50.86 .0002 51.85 .0002 53.86 .0001))
-
-(define bc-a2 '( .99 .1177 1.99 .0047 2.99 .2346 3.99 .0023 4.98 .0538 5.99 .0060 6.98 .0493
- 7.99 .0062 8.99 .0103 9.99 .0030 10.99 .0146 11.99 .0126 12.99 .0042 13.99 .0016 14.99 .0060
- 15.98 .0034 16.96 .0039 17.96 .0036 18.96 .0076 19.96 .0018 20.96 .0025 22.95 .0018 23.95 .0005
- 24.94 .0003 25.95 .0005 26.95 .0006 27.95 .0008 28.96 .0005 29.96 .0005 30.96 .0007 31.95 .0005
- 32.95 .0005 33.95 .0001 34.95 .0003 35.93 .0002 36.94 .0003 38.92 .0002 42.93 .0001 44.93 .0001
- 46.93 .0002 47.92 .0001))
-
-(define bc-as2 '( 1.00 .1279 1.99 .0028 2.99 .1611 3.98 .0034 4.97 .0322 5.97 .0085 6.98 .0274
- 7.97 .0068 8.96 .0245 9.97 .0022 10.94 .0254 11.93 .0010 12.93 .0078 13.95 .0022 14.94 .0035
- 15.92 .0022 16.92 .0033 17.91 .0039 18.90 .0037 19.92 .0012 20.92 .0003 21.91 .0008 22.89 .0005
- 23.88 .0007 24.87 .0007 25.87 .0005 26.88 .0007 27.86 .0001 28.86 .0014 29.84 .0004 30.85 .0005
- 31.85 .0001 32.85 .0004 33.84 .0004 34.84 .0003 36.82 .0003 40.81 .0003 42.80 .0001 43.79 .0002
- 44.79 .0002 45.79 .0003 46.79 .0001 47.79 .0002 49.77 .0001))
-
-(define bc-b2 '( 1.00 .1161 1.98 .0036 2.97 .1813 3.98 .0038 4.96 .0298 5.95 .0073 6.95 .0125
- 7.95 .0064 8.92 .0175 9.94 .0087 10.91 .0117 11.91 .0025 12.91 .0055 13.92 .0027 14.88 .0069
- 15.88 .0034 16.88 .0052 17.85 .0038 18.88 .0003 19.83 .0005 20.83 .0005 21.78 .0002 22.82 .0004
- 23.74 .0002 24.81 .0008 25.76 .0003 26.78 .0005 27.78 .0006 28.78 .0005 29.74 .0002 30.75 .0001
- 31.75 .0004 32.72 .0002 33.73 .0002 34.73 .0002 41.69 .0002 42.68 .0002 43.67 .0002 44.68 .0002
- 45.67 .0001))
-
-(define bc-c3 '( 1.00 .1579 1.99 .0068 2.99 .1885 3.99 .0022 4.97 .0384 5.96 .0054 6.97 .0247
- 7.97 .0023 8.96 .0114 9.95 .0096 10.93 .0054 11.95 .0030 12.94 .0036 13.92 .0075 14.93 .0033
- 15.92 .0052 16.91 .0010 17.91 .0011 18.90 .0004 19.89 .0006 20.90 .0005 21.89 .0003 22.87 .0004
- 23.88 .0004 24.87 .0005 25.86 .0008 26.87 .0005 27.85 .0002 28.84 .0002 29.85 .0003 30.83 .0002
- 31.84 .0002 32.83 .0002 35.83 .0001 36.80 .0002 38.81 .0002 39.78 .0002 40.78 .0003 41.79 .0001))
-
-(define bc-cs3 '( 1.00 .2106 1.98 .0073 2.99 .1027 3.98 .0038 4.97 .0191 5.98 .0036 6.97 .0256
- 7.95 .0035 8.97 .0347 9.95 .0039 10.94 .0048 11.95 .0026 12.94 .0089 13.93 .0011 14.93 .0052
- 15.93 .0033 16.96 .0002 17.93 .0003 18.94 .0001 19.92 .0002 20.91 .0007 21.91 .0006 22.89 .0005
- 23.90 .0005 24.90 .0005 25.87 .0005 26.89 .0003 27.88 .0005 28.87 .0003 29.87 .0003 31.85 .0002
- 33.84 .0001 34.84 .0001 36.82 .0003 37.83 .0001 38.83 .0003))
-
-(define bc-d3 '( 1.01 .2039 2.00 .0041 3.00 .0640 3.99 .0062 5.00 .0192 6.00 .0013 7.01 .0225
- 8.00 .0034 9.01 .0245 10.00 .0038 11.02 .0028 12.01 .0030 13.02 .0042 14.00 .0021 15.01 .0049
- 16.02 .0006 17.02 .0003 18.02 .0007 19.00 .0001 20.03 .0005 21.02 .0010 22.05 .0002 23.04 .0012
- 24.05 .0003 25.02 .0002 26.03 .0003 27.02 .0004 28.03 .0001 29.05 .0002 30.05 .0001 33.03 .0001
- 34.04 .0001 35.04 .0001 36.04 .0003 38.05 .0001 40.04 .0001))
-
-(define bc-ds3 '( 1.01 .1501 2.00 .0036 3.00 .0682 4.00 .0069 4.99 .0142 5.98 .0017 6.99 .0322
- 7.99 .0063 8.98 .0019 10.00 .0010 11.00 .0046 11.99 .0023 12.99 .0035 13.98 .0041 14.98 .0020
- 15.97 .0001 16.98 .0003 17.98 .0008 18.98 .0009 20.03 .0002 21.00 .0007 21.99 .0006 22.99 .0006
- 23.99 .0003 24.98 .0004 25.98 .0003 26.97 .0001 27.98 .0001 29.97 .0001 30.98 .0002 32.96 .0003
- 33.97 .0003 34.95 .0002 35.96 .0002 36.97 .0001))
-
-(define bc-e3 '( .99 .1413 1.99 .0047 3.00 .0710 4.01 .0016 5.01 .0154 6.01 .0063 7.01 .0122
- 8.02 .0179 9.00 .0044 10.00 .0082 11.01 .0058 12.01 .0031 13.02 .0045 14.02 .0027 15.02 .0004
- 16.03 .0010 17.01 .0008 18.04 .0002 19.04 .0004 20.03 .0006 21.04 .0004 22.03 .0003 23.04 .0004
- 24.04 .0002 25.04 .0003 26.06 .0001 27.04 .0003 28.03 .0002 29.02 .0003 30.99 .0002 32.04 .0006
- 33.03 .0002 34.04 .0003 36.04 .0001))
-
-(define bc-f3 '( .99 .2534 1.99 .0057 3.00 .0476 3.98 .0101 4.98 .0334 5.97 .0066 6.98 .0489
- 7.96 .0038 8.96 .0096 9.95 .0008 10.96 .0056 11.95 .0049 12.95 .0029 13.95 .0002 14.95 .0006
- 15.96 .0002 16.96 .0008 17.94 .0004 18.93 .0002 19.94 .0009 20.94 .0002 21.93 .0004 22.94 .0004
- 23.93 .0004 25.90 .0004 26.90 .0003 27.89 .0001 28.91 .0004 29.87 .0001 30.89 .0005 32.89 .0002
- 33.87 .0001))
-
-(define bc-fs3 '( 1.00 .3131 1.99 .0095 3.00 .0885 3.99 .0194 4.98 .0653 5.99 .0049 6.98 .0528
- 7.99 .0038 8.98 .0129 9.97 .0042 10.98 .0063 11.97 .0023 12.97 .0016 13.98 .0002 14.97 .0004
- 15.97 .0005 16.97 .0006 17.96 .0001 18.96 .0008 20.95 .0007 21.96 .0001 22.95 .0001 23.94 .0003
- 25.94 .0004 26.95 .0004 27.94 .0005 28.93 .0003 29.94 .0003 31.93 .0002 33.92 .0002))
-
-(define bc-g3 '( 1.00 .2177 2.01 .0024 3.01 .0126 4.02 .0067 5.02 .0577 6.02 .0083 7.02 .0215
- 8.03 .0034 9.03 .0047 10.04 .0046 11.05 .0143 12.04 .0037 13.04 .0010 14.05 .0005 15.06 .0005
- 16.06 .0003 17.06 .0002 18.06 .0004 19.09 .0001 20.08 .0003 21.08 .0002 23.08 .0003 24.08 .0003
- 25.08 .0001 26.10 .0010 27.11 .0002 28.10 .0004 30.12 .0003 32.13 .0003))
-
-(define bc-gs3 '( 1.01 .1420 2.01 .0026 3.01 .0289 4.03 .0162 5.03 .0373 6.02 .0015 7.03 .0112
- 8.05 .0068 9.05 .0063 10.04 .0027 11.06 .0022 12.07 .0004 13.06 .0008 14.07 .0011 15.08 .0003
- 16.08 .0002 17.09 .0005 19.11 .0003 23.12 .0004 24.12 .0003 25.14 .0002 26.14 .0003 27.14 .0002
- 28.14 .0002 29.16 .0002 30.16 .0001 34.18 .0002))
-
-(define bc-a3 '( 1.01 .2365 2.02 .0034 3.03 .0242 4.04 .0251 5.04 .0203 6.06 .0078 7.06 .0213
- 8.08 .0162 9.09 .0121 10.10 .0053 11.11 .0024 12.12 .0028 13.14 .0010 14.13 .0006 15.15 .0009
- 16.16 .0008 17.17 .0009 18.18 .0006 19.19 .0003 20.20 .0003 21.20 .0003 22.22 .0004 23.22 .0002
- 24.24 .0007 26.26 .0003 27.26 .0001 29.29 .0003))
-
-(define bc-as3 '( 1.00 .1078 2.01 .0072 3.02 .0487 4.04 .0332 5.05 .0329 6.06 .0069 7.07 .0153
- 8.08 .0061 9.08 .0082 10.09 .0023 11.10 .0003 12.11 .0009 13.12 .0008 14.13 .0007 15.15 .0003
- 16.16 .0006 17.16 .0007 18.16 .0003 19.17 .0003 20.18 .0005 21.19 .0005 22.20 .0005 23.22 .0004
- 24.23 .0001 26.25 .0001 27.25 .0001 28.26 .0001))
-
-(define bc-b3 '( 1.01 .0572 2.02 .0086 3.03 .0724 4.04 .0057 5.04 .0365 6.05 .0058 7.06 .0083
- 8.07 .0113 9.08 .0102 10.09 .0022 11.10 .0012 12.11 .0005 13.11 .0014 14.12 .0003 15.13 .0008
- 16.14 .0009 17.15 .0003 18.16 .0002 19.17 .0006 20.18 .0009 21.19 .0002 22.19 .0006 23.20 .0004
- 24.21 .0004 25.22 .0001))
-
-(define bc-c4 '( 1.01 .0509 2.02 .0146 3.02 .0344 4.03 .0126 5.04 .0254 6.05 .0004 7.05 .0134
- 8.06 .0069 9.08 .0007 10.09 .0005 11.09 .0006 12.09 .0004 13.11 .0010 14.12 .0001 15.12 .0008
- 16.13 .0001 17.14 .0003 18.15 .0002 19.17 .0001 20.16 .0004 21.17 .0002))
-
-(define bc-cs4 '( 1.00 .1853 2.00 .0169 3.01 .0922 4.01 .0035 5.01 .0204 6.01 .0046 7.02 .0077
- 8.02 .0085 9.02 .0028 10.05 .0002 11.02 .0003 12.03 .0006 13.05 .0002 14.03 .0006 15.04 .0006
- 16.04 .0004 17.02 .0003 18.04 .0006 19.04 .0004 20.04 .0003 21.06 .0001 22.04 .0001 23.06 .0002))
-
-(define bc-d4 '( 1.00 .3391 2.00 .0134 2.99 .0186 3.99 .0424 4.98 .0122 5.98 .0055 6.97 .0197
- 7.98 .0034 8.97 .0017 9.98 .0004 10.96 .0008 11.96 .0009 12.96 .0003 13.96 .0007 14.95 .0004
- 15.94 .0002 16.95 .0003 17.94 .0008 18.93 .0002 19.93 .0001))
-
-(define bc-ds4 '( .99 .3684 1.98 .0187 2.98 .0647 3.97 .0186 4.97 .0070 5.96 .0127 6.95 .0173
- 7.94 .0011 8.94 .0011 9.93 .0014 10.92 .0013 11.90 .0001 12.90 .0006 13.91 .0003 14.89 .0003
- 15.89 .0001 16.88 .0010 17.88 .0004 18.86 .0001 19.86 .0002 20.85 .0001))
-
-(define bc-e4 '( 1.00 .5390 3.01 .0188 4.00 .0247 5.00 .0129 6.01 .0050 7.01 .0014 8.01 .0012
- 9.01 .0012 10.01 .0010 11.02 .0005 12.02 .0002 13.03 .0004))
-
-(define bc-f4 '( 1.01 .5398 2.01 .0309 3.01 .0727 4.01 .0062 5.01 .0041 6.02 .0280 7.02 .0005
- 8.02 .0014 9.02 .0013 10.02 .0030 11.03 .0006 12.03 .0004 14.03 .0003 15.04 .0003 16.04 .0007))
-
-(define bc-fs4 '( 1.00 .6398 2.01 .0314 3.01 .0423 4.01 .0292 5.01 .0093 6.02 .0088 7.02 .0010
- 8.03 .0043 9.02 .0004 10.03 .0013 11.03 .0003 12.04 .0003 13.02 .0002 14.04 .0010 15.04 .0006
- 16.05 .0001 17.04 .0003))
-
-(define bc-g4 '( 1.00 .5985 1.99 .0192 2.99 .0346 3.99 .0257 4.98 .0082 5.98 .0037 6.98 .0008
- 7.99 .0013 8.97 .0014 9.98 .0016 10.98 .0010 11.98 .0005 12.97 .0005 13.97 .0008 14.95 .0002
- 15.96 .0003))
-
-(define bc-gs4 '( 1.00 .2635 1.99 .0230 2.99 .0936 3.99 .0214 4.99 .0320 5.99 .0013 6.99 .0020
- 7.99 .0004 8.99 .0014 9.99 .0003 10.99 .0003 11.98 .0005 12.98 .0015 13.98 .0005 14.98 .0003
- 15.98 .0003 18.98 .0001))
-
-(define bc-a4 '( 1.00 .1539 2.00 .0355 3.00 .0834 4.01 .0210 5.01 .0103 6.00 .0035 7.02 .0004
- 8.01 .0008 9.00 .0002 10.01 .0001 11.01 .0005 12.01 .0007 13.02 .0011 14.01 .0003 15.02 .0003
- 18.02 .0002))
-
-(define bc-as4 '( 1.00 .1843 2.01 .0229 3.00 .0348 4.01 .0157 5.01 .0170 6.01 .0037 7.02 .0012
- 8.02 .0027 9.02 .0003 10.02 .0011 11.03 .0010 12.03 .0007 13.03 .0004 14.03 .0002 15.03 .0002
- 17.04 .0002))
-
-(define bc-b4 '( 1.00 .5063 2.01 .0563 3.01 .0376 4.01 .0383 5.01 .0135 6.02 .0081 7.02 .0011
- 8.02 .0049 9.03 .0007 10.03 .0006 11.04 .0013 12.04 .0007 13.04 .0004 14.05 .0002 15.05 .0002
- 17.05 .0002 19.06 .0001))
-
-(define bc-c5 '( 1.00 .5459 2.00 .0278 3.01 .0456 4.01 .0648 5.02 .0035 6.02 .0050 7.02 .0025
- 8.02 .0021 9.02 .0005 10.03 .0007 11.03 .0016 12.03 .0007 13.04 .0001 14.03 .0002 15.04 .0002
- 18.05 .0002 19.05 .0001 20.05 .0002))
-
-(define bc-cs5 '( 1.00 .2584 2.01 .0583 3.02 .1090 4.02 .0290 5.02 .0020 6.03 .0018 7.03 .0016
- 8.03 .0001 9.04 .0005 10.05 .0017 11.05 .0010 12.05 .0002 13.06 .0001 14.06 .0001 17.08 .0002
- 18.08 .0001 19.08 .0001))
-
-(define bc-d5 '( 1.00 .1626 2.00 .0485 3.01 .0856 4.00 .0023 5.01 .0096 6.01 .0042 7.01 .0015
- 8.01 .0004 9.02 .0019 10.02 .0016 11.02 .0003 12.02 .0002 13.02 .0002 16.03 .0001 17.03 .0001
- 18.03 .0002 19.03 .0001))
-
-(define bc-ds5 '( 1.00 .1756 1.99 .1645 2.99 .0381 3.98 .0028 4.98 .0042 5.98 .0004 6.97 .0025
- 7.97 .0006 8.96 .0022 9.96 .0011 10.96 .0002 13.94 .0002 14.94 .0002 15.94 .0001 16.93 .0001
- 17.93 .0001))
-
-(define bc-e5 '( .99 .2661 1.99 .1398 2.99 .0589 3.99 .0048 4.98 .0022 5.98 .0015 6.97 .0021
- 7.97 .0008 8.96 .0011 9.96 .0009 10.95 .0004 11.94 .0001 13.94 .0001 14.94 .0001 15.94 .0001))
-
-(define bc-f5 '( 1.00 .1378 2.00 .0654 3.00 .1301 4.00 .0049 5.00 .0030 6.01 .0018 7.01 .0030
- 8.01 .0015 9.01 .0008 10.01 .0001 11.01 .0003 12.01 .0002 13.01 .0001 14.01 .0002 15.01 .0002
- 16.02 .0001))
-
-(define bc-fs5 '( 1.00 .3952 2.01 .1124 3.01 .0326 4.02 .0104 5.03 .0013 6.03 .0010 7.03 .0009
- 8.04 .0009 9.05 .0002 10.05 .0003 11.05 .0001 13.06 .0002 14.07 .0003 15.08 .0002))
-
-(define bc-g5 '( 1.01 .3434 2.01 .0390 3.02 .0051 4.03 .0057 5.04 .0042 6.05 .0017 7.06 .0022
- 8.06 .0012 9.07 .0002 10.07 .0001 11.08 .0002 12.09 .0002 13.10 .0002 14.11 .0002 15.12 .0001))
-
-(define bc-gs5 '( 1.00 .1109 1.99 .0911 2.98 .0061 3.98 .0062 4.98 .0020 5.97 .0006 6.96 .0008
- 7.96 .0013 8.95 .0002 10.94 .0002 11.94 .0002 12.93 .0002 13.93 .0001))
-
-(define bc-a5 '( 1.00 .1585 2.00 .0562 3.00 .0039 4.00 .0064 5.00 .0016 6.00 .0022 7.00 .0009
- 8.00 .0004 9.00 .0002 11.00 .0003 12.00 .0003 13.00 .0002 14.00 .0002))
-
-(define bc-as5 '( .99 .1211 1.98 .0394 2.97 .0093 3.96 .0024 4.95 .0030 5.94 .0027 6.93 .0006
- 8.92 .0002 10.90 .0001 12.88 .0001))
-
-;;;
-;;;
-;;;
-;;;
-;;; bassoon?
-(define bsn-as1 '( 1.00 .0038 2.02 .0235 3.04 .0511 4.06 .0348 5.07 .0491 6.09 .0518 7.11 .0184
- 8.12 .0381 9.11 .1027 10.13 .0412 11.15 .0112 12.17 .0144 13.18 .0097 14.20 .0074 15.21 .0081
- 16.23 .0067 17.22 .0108 18.24 .0113 19.25 .0114 20.28 .0066 21.30 .0065 22.32 .0035 23.33 .0041
- 24.33 .0036 25.34 .0025 26.35 .0010 27.37 .0021 28.39 .0007 29.42 .0006 30.42 .0009 31.43 .0005
- 32.43 .0003 33.46 .0005 34.46 .0002 35.48 .0002 36.48 .0004 37.52 .0003 38.53 .0003 39.55 .0002
- 40.56 .0002 51.69 .0001 54.72 .0002))
-
-(define bsn-b1 '( 1.01 .0039 2.02 .0230 3.02 .0517 4.03 .0473 5.03 .0443 6.03 .0691 7.03 .0664
- 8.04 .0408 9.04 .1283 10.06 .0429 11.07 .0339 12.08 .0223 13.08 .0207 14.08 .0256 15.08 .0171
- 16.09 .0106 17.09 .0136 18.09 .0082 19.12 .0052 20.12 .0041 21.13 .0015 22.13 .0023 23.12 .0021
- 24.12 .0009 25.13 .0029 26.14 .0014 27.15 .0003 28.15 .0010 29.17 .0013 30.18 .0003 31.19 .0005
- 32.19 .0007 33.19 .0004 34.20 .0005 35.19 .0005 36.19 .0003 37.21 .0003 38.23 .0002 39.23 .0001
- 40.23 .0001 43.23 .0001 46.26 .0002 49.27 .0002 51.27 .0003 52.27 .0002 53.28 .0002))
-
-(define bsn-c2 '( 1.01 .0047 2.03 .0390 3.04 .0460 4.04 .0217 5.05 .0464 6.05 .0631 7.06 .0874
- 8.07 .1167 9.08 .0339 10.09 .0209 11.11 .0133 12.12 .0088 13.11 .0092 14.14 .0032 15.15 .0026
- 16.16 .0061 17.17 .0019 18.17 .0051 19.18 .0161 20.18 .0048 21.20 .0044 22.21 .0035 23.23 .0010
- 24.24 .0028 25.25 .0006 26.26 .0013 27.27 .0016 28.26 .0002 29.28 .0006 30.28 .0006 31.30 .0004
- 32.32 .0012 33.33 .0003 34.34 .0003 35.35 .0002 36.34 .0001 43.41 .0001 46.43 .0001 48.44 .0001
- 51.48 .0001))
-
-(define bsn-cs2 '( 1.01 .0090 2.02 .0531 3.01 .0318 4.01 .0199 5.02 .0211 6.04 .0629 7.04 .1340
- 8.05 .0925 9.04 .0206 10.04 .0584 11.05 .0140 12.07 .0066 13.08 .0068 14.08 .0011 15.07 .0028
- 16.07 .0015 17.08 .0041 18.10 .0106 19.10 .0034 20.10 .0033 21.10 .0020 22.10 .0021 23.11 .0040
- 24.13 .0001 25.12 .0004 26.13 .0003 28.13 .0004 29.14 .0002 30.16 .0001 31.17 .0001 43.20 .0001
- 46.22 .0002))
-
-(define bsn-d2 '( 1.01 .0616 2.00 .0436 3.00 .0430 3.99 .0491 5.01 .0358 6.01 .1695 7.00 .1562
- 7.99 .0174 8.99 .0062 10.01 .0054 11.00 .0104 12.00 .0055 12.99 .0052 13.99 .0018 15.00 .0021
- 16.00 .0019 16.99 .0087 17.98 .0025 18.99 .0027 20.00 .0015 21.00 .0024 21.98 .0015 22.99 .0002
- 24.00 .0006 25.99 .0001 26.95 .0001 28.00 .0001 28.94 .0001 30.01 .0002))
-
-(define bsn-ds2 '( 1.01 .0769 2.01 .0341 3.00 .0240 4.00 .0633 5.00 .0124 5.99 .0850 6.99 .1044
- 7.99 .0115 8.99 .0046 10.00 .0048 11.00 .0054 12.00 .0082 13.00 .0033 14.00 .0080 15.00 .0022
- 15.99 .0081 16.99 .0028 17.98 .0038 18.98 .0028 19.99 .0032 20.99 .0007 22.00 .0003 22.98 .0004
- 23.99 .0001 24.98 .0005 25.98 .0002 26.97 .0003 28.98 .0001 38.97 .0001 40.97 .0001))
-
-(define bsn-e2 '( 1.00 .0369 1.98 .0190 3.00 .0291 3.98 .0844 5.00 .0730 5.98 .0856 7.00 .0563
- 7.98 .0792 9.00 .0139 9.97 .0127 10.99 .0046 11.96 .0052 12.99 .0043 13.97 .0030 14.99 .0102
- 15.98 .0020 16.97 .0029 17.98 .0010 18.96 .0040 19.98 .0008 20.97 .0004 21.99 .0001 23.98 .0004
- 25.96 .0002 26.93 .0001 36.94 .0001))
-
-(define bsn-f2 '( .99 .0208 2.00 .0164 3.01 .0576 4.02 .0547 5.02 .0965 5.99 .1701 7.00 .0206
- 8.01 .0040 9.02 .0075 10.02 .0033 11.00 .0067 12.00 .0021 13.01 .0010 14.02 .0072 15.03 .0014
- 16.01 .0028 17.01 .0034 18.02 .0026 19.03 .0007 20.05 .0004 20.43 .0001 22.02 .0001 24.01 .0003
- 26.03 .0001))
-
-(define bsn-fs2 '( 1.00 .0112 1.99 .0211 2.98 .0379 3.97 .0630 4.98 .0727 5.97 .1555 6.95 .0348
- 7.94 .0362 8.96 .0083 9.94 .0145 10.92 .0070 11.91 .0031 12.93 .0059 13.92 .0054 14.91 .0024
- 15.89 .0024 16.88 .0045 17.90 .0013 18.91 .0007 19.87 .0005 20.87 .0004 21.88 .0002 22.85 .0007
- 23.84 .0003 24.83 .0002 26.84 .0001 28.80 .0002 29.80 .0001 30.81 .0003 31.81 .0001 32.78 .0003
- 33.77 .0001 34.79 .0002))
-
-(define bsn-g2 '( .98 .0330 1.99 .0314 2.95 .0487 3.95 .0272 4.95 .2864 5.91 .0849 6.92 .0047
- 7.89 .0049 8.88 .0015 9.88 .0060 10.85 .0051 11.85 .0013 12.83 .0083 13.82 .0018 14.82 .0010
- 15.78 .0032 16.79 .0007 17.77 .0004 18.76 .0005 19.76 .0008 20.72 .0004 21.72 .0009 22.72 .0003
- 23.69 .0002))
-
-(define bsn-gs2 '( .98 .0321 1.98 .0281 2.99 .0196 3.99 .0683 4.96 .2698 5.95 .0125 6.95 .0153
- 7.96 .0034 8.96 .0050 9.93 .0056 10.92 .0049 11.92 .0160 12.92 .0072 13.91 .0013 14.89 .0028
- 15.91 .0005 16.86 .0004 17.89 .0006 18.89 .0009 19.87 .0005 20.85 .0001 21.87 .0003 27.83 .0001
- 28.82 .0002))
-
-(define bsn-a2 '( .99 .0170 2.00 .0296 3.00 .0324 4.01 .1542 5.02 .1393 6.02 .0249 7.03 .0041
- 8.03 .0022 9.01 .0043 10.02 .0077 11.03 .0092 12.04 .0021 13.04 .0027 14.05 .0026 15.06 .0007
- 16.05 .0001 17.05 .0003 18.04 .0006 19.04 .0004 20.05 .0002 26.06 .0003 27.06 .0002 29.07 .0001))
-
-(define bsn-as2 '( 1.01 .0153 2.00 .0261 3.00 .0305 3.99 .1573 4.97 .0908 5.98 .0053 6.97 .0054
- 7.98 .0159 8.99 .0031 9.99 .0015 10.96 .0124 11.96 .0020 12.95 .0026 13.94 .0034 14.94 .0005
- 16.95 .0007 17.93 .0002 18.94 .0003 24.92 .0002 25.91 .0002 27.89 .0002 28.89 .0001))
-
-(define bsn-b2 '( 1.01 .0061 2.00 .0199 2.99 .0393 3.98 .2060 5.00 .0178 5.99 .0340 6.98 .0029
- 7.98 .0065 8.99 .0102 9.99 .0271 10.98 .0068 11.97 .0032 12.97 .0060 13.99 .0002 14.98 .0005
- 15.96 .0008 16.96 .0008 17.98 .0006 18.98 .0001 21.96 .0001 22.96 .0002 23.95 .0002 24.94 .0002
- 25.94 .0001 26.95 .0001 28.95 .0001))
-
-(define bsn-c3 '( 1.00 .0082 1.98 .0489 2.99 .1248 3.98 .1892 4.97 .0149 5.98 .0017 6.96 .0172
- 7.95 .0072 8.96 .0028 9.95 .0114 10.93 .0055 11.94 .0029 12.96 .0005 13.92 .0017 14.93 .0008
- 15.91 .0012 16.90 .0005 17.91 .0001 20.90 .0001 21.88 .0003 22.87 .0001 24.85 .0002 28.85 .0001))
-
-(define bsn-cs3 '( 1.01 .0191 2.00 .0451 2.99 .2847 4.00 .0925 5.00 .0143 5.99 .0024 7.00 .0055
- 8.00 .0131 8.99 .0286 9.98 .0021 10.99 .0020 11.99 .0010 12.96 .0003 13.97 .0005 14.98 .0009
- 15.97 .0005 20.97 .0003 21.97 .0003))
-
-(define bsn-d3 '( 1.01 .0218 2.01 .0560 3.01 .1696 4.01 .0504 5.00 .0268 6.02 .0018 7.03 .0081
- 8.03 .0035 9.04 .0026 10.04 .0023 11.02 .0045 12.04 .0002 13.04 .0004 14.04 .0007 15.05 .0004
- 16.06 .0001 21.06 .0001 22.07 .0003))
-
-(define bsn-ds3 '( 1.00 .0185 1.99 .0627 2.98 .2037 3.97 .0211 4.98 .0204 5.97 .0434 6.95 .0056
- 7.94 .0171 8.95 .0014 9.94 .0062 10.93 .0007 11.91 .0006 12.91 .0004 13.90 .0004 14.90 .0003
- 16.88 .0001 17.89 .0002 18.88 .0002 20.86 .0004 21.84 .0002 22.85 .0001))
-
-(define bsn-e3 '( 1.00 .0167 2.00 .0801 3.01 .2223 4.02 .0252 5.02 .0098 6.01 .0058 7.02 .0073
- 8.03 .0032 9.03 .0066 10.04 .0011 10.66 .0001 12.04 .0013 13.04 .0013 14.05 .0010 15.05 .0004
- 18.07 .0002 20.06 .0003 23.07 .0001))
-
-(define bsn-f3 '( 1.00 .0152 2.01 .0471 3.00 .1985 4.00 .0345 5.01 .0136 6.00 .0064 7.01 .0153
- 8.00 .0011 9.00 .0093 10.02 .0006 11.01 .0006 12.00 .0001 13.01 .0008 14.01 .0006 16.02 .0001
- 17.01 .0003 19.01 .0002 22.01 .0001 23.02 .0002))
-
-(define bsn-fs3 '( 1.01 .0363 2.01 .1019 3.01 .3226 4.01 .1274 5.03 .0397 6.03 .0061 7.02 .0117
- 8.03 .0099 9.04 .0006 10.04 .0026 11.04 .0020 12.04 .0008 13.05 .0001 14.06 .0002 15.05 .0002
- 19.07 .0002))
-
-(define bsn-g3 '( .99 .0358 1.99 .0535 2.99 .1072 3.99 .0270 4.99 .0106 5.98 .0010 6.97 .0007
- 7.97 .0041 8.95 .0002 9.94 .0002 10.97 .0002 12.96 .0001))
-
-(define bsn-gs3 '( 1.00 .0382 1.99 .0923 2.99 .0199 3.99 .0156 4.96 .0044 5.98 .0130 6.97 .0020
- 7.97 .0033 8.97 .0007 9.95 .0002 10.95 .0001 12.95 .0001))
-
-(define bsn-a3 '( 1.00 .0469 2.00 .2187 3.00 .0287 4.01 .0121 5.01 .0114 6.01 .0022 7.01 .0044
- 8.02 .0008 9.02 .0004 10.01 .0003 13.02 .0001))
-
-(define bsn-as3 '( 1.01 .0298 2.01 .2016 3.02 .0058 4.00 .0258 5.00 .0008 6.00 .0029 7.00 .0031
- 8.01 .0010 9.01 .0004 10.00 .0001 13.01 .0001))
-
-(define bsn-b3 '( 1.01 .0341 2.01 .2100 3.01 .0390 4.02 .0044 5.02 .0213 6.02 .0044 7.02 .0006
- 8.03 .0012 9.04 .0002 12.05 .0002 13.05 .0002))
-
-(define bsn-c4 '( 1.00 .0684 2.00 .2934 3.00 .0096 4.00 .0084 5.00 .0039 6.00 .0059 7.00 .0010
- 8.00 .0006))
-
-(define bsn-cs4 '( 1.01 .0848 2.01 .3334 3.02 .0152 4.03 .0032 5.03 .0059 6.03 .0032 7.05 .0013
- 8.05 .0007 9.05 .0001 10.06 .0001 11.06 .0002))
-
-(define bsn-d4 '( 1.00 .1020 2.00 .1065 3.00 .0086 3.99 .0013 5.00 .0038 6.00 .0011 7.00 .0003
- 8.00 .0002 11.01 .0003))
-
-(define bsn-ds4 '( 1.00 .0469 1.99 .0248 2.96 .0045 3.99 .0163 4.99 .0042 6.00 .0004 6.98 .0003))
-
-(define bsn-e4 '( 1.00 .0389 2.01 .0439 3.01 .0110 4.01 .0072 5.02 .0041 6.02 .0005 7.02 .0006
- 9.03 .0003))
-
-(define bsn-f4 '( 1.00 .0229 2.00 .0331 2.99 .0138 4.00 .0008 4.99 .0010 5.99 .0004))
-
-(define bsn-fs4 '( 1.00 .1522 1.99 .0563 3.00 .0126 3.99 .0035 4.28 .0002 4.35 .0002 4.43 .0001
- 4.98 .0001 5.99 .0001 6.98 .0002))
-
-(define bsn-g4 '( 1.00 .0415 2.00 .0486 3.00 .0068 4.00 .0148 5.00 .0016 6.00 .0001))
-
-(define bsn-gs4 '( 1.01 .0811 2.01 .0402 3.03 .0114 4.04 .0044 5.03 .0004))
-
-(define bsn-a4 '( 1.00 .0399 2.01 .0195 3.00 .0069 4.01 .0005 5.01 .0009 6.01 .0002 7.01 .0003))
-
-(define bsn-as4 '( 1.01 .1259 2.01 .0811 3.01 .0051 4.01 .0027 5.01 .0008 6.02 .0002 7.02 .0003))
-
-(define bsn-b4 '( 1.01 .1159 2.02 .0380 3.03 .0089 4.04 .0038 5.05 .0006 6.05 .0002))
-
-(define bsn-c5 '( 1.02 .0871 2.03 .0356 3.04 .0192 4.06 .0063 6.09 .0003 7.11 .0002))
-
-(define bsn-cs5 '( 1.01 .2418 2.02 .0674 3.02 .0067 4.03 .0021 5.03 .0004 6.05 .0003 7.05 .0005
- 8.06 .0001))
-
-(define bsn-d5 '( 1.01 .1931 2.01 .0462 3.02 .0118 4.02 .0014 5.03 .0006 6.03 .0008 8.04 .0001))
-
-
-;;;
-;;;
-;;;
-;;;
-;;; cello
-(define c-c2 '( 1.00 .0047 1.99 .0251 2.99 .0546 4.01 .1041 4.99 .0279 5.97 .0219 6.93 .0137
- 7.94 .0349 8.91 .0151 10.04 .0565 11.00 .0458 12.00 .0216 12.97 .0151 14.52 .0025 14.95 .0088
- 16.03 .0103 17.02 .0027 17.98 .0089 19.00 .0052 20.03 .0048 20.93 .0051 22.04 .0023 23.01 .0072
- 24.01 .0022 24.99 .0027 26.03 .0036 27.47 .0011 27.99 .0011 29.02 .0012 29.86 .0005 30.97 .0020
- 31.88 .0006 33.02 .0021 33.98 .0011 35.02 .0010 36.01 .0028 37.00 .0022 37.99 .0014 39.00 .0014
- 40.01 .0022 41.04 .0021 42.02 .0008 43.01 .0024 44.02 .0007 45.01 .0003 46.00 .0002 48.03 .0002
- 48.85 .0002 51.01 .0001 51.98 .0001 54.89 .0002 55.39 .0002 56.38 .0001 58.02 .0002 58.98 .0002
- 62.00 .0001 64.09 .0001 65.02 .0002))
-
-(define c-cs2 '( 1.01 .0160 2.02 .0737 3.02 .0287 4.02 .0183 5.02 .0669 6.04 .0520 7.05 .0043
- 8.06 .0066 9.06 .0194 10.05 .0193 11.05 .0254 12.06 .0153 13.08 .0041 14.11 .0037 15.09 .0098
- 16.09 .0022 17.09 .0053 18.10 .0135 19.12 .0118 20.13 .0057 21.15 .0039 22.14 .0023 23.14 .0027
- 24.15 .0026 25.16 .0012 26.16 .0011 27.17 .0020 28.17 .0015 29.14 .0020 30.19 .0013 31.19 .0019
- 32.20 .0007 33.21 .0005 34.22 .0004 35.19 .0012 36.20 .0005 37.25 .0015 38.25 .0018 39.26 .0014
- 40.40 .0007 41.25 .0010 42.24 .0009 43.28 .0003 44.31 .0002 45.28 .0002 46.30 .0001 48.29 .0002
- 49.31 .0004 50.34 .0001 51.35 .0002 52.32 .0003 53.50 .0001 54.28 .0001 57.34 .0001 58.35 .0002))
-
-(define c-d2 '( 1.00 .0368 2.02 .1070 3.03 .0107 4.04 .0445 5.04 .0477 6.04 .0281 7.07 .0191
- 8.06 .0205 9.06 .0456 10.07 .0283 11.07 .0320 12.08 .0094 13.35 .0009 14.11 .0042 15.11 .0066
- 16.12 .0075 17.13 .0117 18.14 .0043 19.16 .0067 20.14 .0020 21.16 .0046 22.16 .0011 23.17 .0029
- 24.17 .0010 25.18 .0011 26.19 .0013 27.18 .0029 28.20 .0039 29.21 .0048 30.23 .0020 31.23 .0006
- 32.25 .0018 33.23 .0009 34.24 .0012 35.28 .0016 36.27 .0018 37.28 .0019 38.28 .0031 39.28 .0008
- 40.25 .0001 41.30 .0002 42.31 .0002 43.32 .0001 44.32 .0002 45.33 .0002 46.34 .0004 48.37 .0002
- 49.37 .0006 50.37 .0004 51.35 .0001 52.35 .0001 53.40 .0001 54.39 .0002 55.41 .0003 56.43 .0002
- 57.41 .0001 64.49 .0001 65.50 .0001))
-
-(define c-ds2 '( 1.01 .0485 2.01 .1800 3.01 .0143 4.02 .1265 5.03 .1372 6.03 .0102 7.02 .0261
- 8.03 .0216 9.02 .0145 10.04 .0292 11.05 .0133 12.06 .0038 13.06 .0026 14.04 .0041 15.06 .0053
- 16.06 .0014 17.08 .0051 18.06 .0048 19.07 .0026 20.07 .0025 21.09 .0039 22.08 .0018 23.08 .0031
- 24.11 .0023 25.10 .0035 26.10 .0037 27.10 .0019 28.10 .0030 29.11 .0020 30.10 .0036 31.13 .0020
- 32.10 .0011 33.13 .0013 34.12 .0027 35.11 .0022 36.13 .0018 37.15 .0005 38.13 .0002 39.17 .0002
- 40.16 .0006 41.13 .0002 43.16 .0002 44.16 .0002 45.15 .0002 46.18 .0003 47.17 .0001 48.18 .0001
- 49.16 .0002 50.19 .0001 58.35 .0001))
-
-(define c-e2 '( 1.02 .0293 2.00 .1425 3.04 .0549 4.03 .0364 5.03 .1171 6.07 .0100 7.04 .0253
- 8.06 .0448 9.08 .0115 10.06 .0116 11.08 .0048 12.09 .0174 13.09 .0037 14.11 .0029 15.11 .0104
- 16.12 .0036 17.14 .0046 18.13 .0016 19.16 .0027 20.13 .0036 21.14 .0012 22.18 .0027 23.17 .0011
- 24.18 .0033 25.20 .0019 26.20 .0016 26.99 .0005 28.22 .0009 29.19 .0052 30.23 .0021 31.21 .0015
- 32.24 .0014 33.23 .0019 34.22 .0033 35.27 .0009 36.27 .0002 38.30 .0004 39.27 .0005 40.26 .0004
- 41.25 .0003 42.31 .0002 43.34 .0007 44.32 .0006 45.32 .0003 46.36 .0002 47.36 .0001 48.34 .0002
- 49.37 .0002 54.40 .0002 55.40 .0001))
-
-(define c-f2 '( .99 .0765 2.00 .0311 3.02 .0635 4.02 .0223 5.15 .0022 6.01 .0457 7.03 .0278
- 8.04 .0188 9.04 .0344 10.02 .0093 11.00 .0034 12.05 .0172 13.06 .0106 14.07 .0020 15.02 .0011
- 16.06 .0022 17.08 .0027 18.08 .0007 19.05 .0016 20.07 .0015 21.07 .0057 22.10 .0010 23.07 .0030
- 24.07 .0013 25.07 .0019 26.09 .0018 27.10 .0042 28.10 .0020 29.09 .0015 30.12 .0027 31.11 .0021
- 32.13 .0035 33.08 .0003 34.12 .0005 35.12 .0004 36.15 .0008 37.15 .0003 39.14 .0005 40.17 .0003
- 41.15 .0003 42.14 .0002 43.14 .0001 44.17 .0002 51.84 .0001 53.18 .0001 54.22 .0001))
-
-(define c-fs2 '( 1.02 .0680 2.02 .0790 3.03 .0722 4.03 .0851 5.03 .0169 6.03 .0073 7.02 .0859
- 8.02 .0250 9.04 .0073 10.07 .0037 11.04 .0035 12.01 .0009 13.09 .0056 14.05 .0059 15.05 .0031
- 16.07 .0050 17.07 .0034 18.07 .0010 19.47 .0004 20.10 .0045 21.10 .0028 22.09 .0039 23.10 .0032
- 24.11 .0007 25.09 .0017 26.10 .0041 27.16 .0006 28.12 .0021 29.13 .0021 30.39 .0004 31.11 .0013
- 32.17 .0004 33.13 .0005 34.14 .0014 35.07 .0002 36.06 .0001 37.16 .0002 39.18 .0007 40.18 .0002
- 41.22 .0001 42.21 .0002 43.24 .0003 49.15 .0001 51.22 .0001 52.23 .0002))
-
-(define c-g2 '( 1.00 .0434 2.00 .0983 2.99 .0548 3.98 .0364 4.98 .0228 5.97 .0390 6.97 .0091
- 7.96 .0154 9.03 .0078 9.96 .0174 10.98 .0110 11.96 .0125 12.97 .0039 13.94 .0028 14.95 .0057
- 15.94 .0020 16.95 .0046 17.94 .0011 18.97 .0017 19.94 .0010 20.98 .0025 21.94 .0040 22.94 .0030
- 23.91 .0064 24.95 .0013 25.96 .0009 26.94 .0015 27.92 .0014 28.93 .0017 29.91 .0015 30.92 .0010
- 31.49 .0002 32.83 .0002 33.89 .0003 34.92 .0002 36.91 .0003 37.91 .0002 40.84 .0002 41.87 .0002
- 42.89 .0002))
-
-(define c-gs2 '( .98 .0579 1.97 .0445 2.97 .1178 3.97 .0806 4.96 .1095 5.94 .0245 6.92 .0203
- 7.91 .0153 8.92 .0186 9.93 .0129 10.92 .0154 11.89 .0040 12.87 .0036 13.88 .0033 14.74 .0006
- 15.85 .0011 16.86 .0020 17.85 .0026 18.84 .0040 19.84 .0022 20.83 .0022 21.82 .0020 22.80 .0060
- 23.79 .0073 24.81 .0023 25.80 .0030 26.79 .0008 27.77 .0005 28.75 .0012 29.73 .0017 30.75 .0003
- 31.74 .0005 32.74 .0003 33.71 .0003 34.70 .0005 35.72 .0002 36.67 .0003 38.69 .0002 39.71 .0002
- 40.65 .0001))
-
-(define c-a2 '( .99 .0612 1.98 .0094 2.98 .0435 3.98 .0098 4.97 .0550 5.97 .0775 6.96 .0337
- 7.96 .0330 8.97 .0137 9.95 .0122 10.95 .0080 11.94 .0082 13.00 .0009 13.95 .0034 14.96 .0029
- 15.94 .0011 16.94 .0041 17.95 .0060 18.92 .0008 19.97 .0026 20.94 .0009 21.94 .0041 22.92 .0050
- 23.92 .0056 24.93 .0030 25.92 .0015 26.22 .0002 27.90 .0011 28.90 .0004 29.89 .0007 30.89 .0009
- 31.90 .0004 32.91 .0002 33.88 .0005 34.86 .0001 35.89 .0003 36.87 .0006 37.89 .0003 38.93 .0002
- 46.84 .0001 54.82 .0001))
-
-(define c-as2 '( 1.00 .0401 1.99 .0101 2.98 .0769 3.96 .0345 4.96 .0696 5.97 .0342 6.95 .0413
- 7.95 .0130 8.92 .0147 9.93 .0034 10.94 .0135 11.94 .0007 12.92 .0013 13.91 .0017 14.89 .0026
- 15.88 .0019 16.89 .0039 17.88 .0034 18.86 .0037 19.84 .0009 20.85 .0021 21.86 .0021 22.85 .0049
- 23.82 .0042 24.82 .0007 25.80 .0007 26.82 .0003 27.81 .0004 28.79 .0009 29.79 .0007 30.77 .0005
- 31.18 .0001 31.66 .0001 32.76 .0002 33.78 .0002 34.76 .0004 35.75 .0002 36.74 .0002))
-
-(define c-b2 '( 1.00 .0486 1.99 .0621 2.98 .0627 3.98 .0145 4.98 .0494 5.97 .0353 6.96 .0287
- 7.96 .0169 8.95 .0167 9.95 .0039 10.94 .0075 11.94 .0043 12.95 .0018 13.92 .0040 14.94 .0054
- 15.93 .0046 16.93 .0035 17.92 .0037 18.93 .0036 19.91 .0055 20.89 .0055 21.89 .0058 22.89 .0039
- 23.88 .0005 24.87 .0009 25.87 .0003 26.87 .0007 27.78 .0002 28.86 .0004 29.86 .0004 30.85 .0004
- 31.86 .0001 32.83 .0009 33.83 .0003 34.82 .0001 37.81 .0002 43.79 .0001 48.71 .0001))
-
-(define c-c3 '( .99 .0486 1.98 .1268 2.99 .0920 3.98 .0752 4.96 .1515 5.95 .0086 6.97 .0102
- 7.95 .0108 8.95 .0120 9.94 .0034 10.95 .0029 11.94 .0007 12.91 .0029 13.92 .0077 14.90 .0028
- 15.89 .0027 16.90 .0038 17.92 .0034 18.87 .0115 19.89 .0039 20.89 .0023 21.86 .0023 22.88 .0008
- 23.88 .0006 24.86 .0004 26.05 .0002 26.84 .0003 27.84 .0005 28.84 .0003 29.80 .0004 30.82 .0007
- 31.58 .0001 31.79 .0001 32.52 .0001 33.80 .0001 34.80 .0001 39.78 .0002))
-
-(define c-cs3 '( 1.01 .0839 1.99 .0414 2.99 .1265 4.00 .0196 5.00 .0377 6.00 .0117 6.99 .0111
- 8.00 .0151 9.00 .0207 9.98 .0033 10.99 .0090 11.99 .0039 13.00 .0039 14.01 .0031 14.99 .0038
- 16.02 .0023 17.00 .0026 17.98 .0069 19.00 .0020 20.01 .0017 21.02 .0007 22.02 .0006 22.22 .0002
- 22.93 .0001 24.05 .0003 25.04 .0002 25.99 .0003 27.00 .0003 29.03 .0003))
-
-(define c-d3 '( 1.01 .1033 2.00 .0588 3.00 .0184 4.00 .0725 5.00 .0720 6.01 .0251 7.01 .0292
- 8.02 .0069 9.00 .0094 10.00 .0159 11.02 .0134 12.00 .0008 13.01 .0053 14.01 .0204 15.01 .0122
- 16.02 .0024 17.03 .0044 18.02 .0069 19.03 .0043 20.01 .0024 21.02 .0020 22.03 .0006 23.03 .0005
- 24.02 .0006 25.01 .0011 26.01 .0006 27.03 .0007 28.04 .0005 29.04 .0003 30.02 .0001 31.03 .0002
- 32.04 .0003 36.02 .0002 38.03 .0001 39.06 .0002 40.01 .0002 42.09 .0001 43.08 .0001 44.05 .0002))
-
-(define c-ds3 '( 1.01 .1622 2.01 .1721 3.02 .0068 4.02 .0256 5.03 .0568 6.02 .0438 7.03 .0061
- 8.04 .0086 9.04 .0050 10.06 .0045 11.07 .0012 12.10 .0025 13.08 .0028 14.11 .0014 15.07 .0060
- 16.07 .0014 17.13 .0026 18.08 .0015 19.13 .0007 20.13 .0003 21.15 .0003 22.06 .0004 23.10 .0002
- 24.15 .0001 25.12 .0001 26.16 .0002 27.20 .0001))
-
-(define c-e3 '( 1.00 .1620 2.01 .0201 3.01 .0224 4.02 .0903 5.03 .0425 6.01 .0323 7.02 .0089
- 8.11 .0023 9.02 .0050 10.03 .0055 11.05 .0038 12.04 .0099 13.04 .0062 14.03 .0027 15.06 .0040
- 16.07 .0035 17.07 .0089 18.06 .0013 19.05 .0012 20.08 .0004 21.06 .0008 22.09 .0002 23.08 .0008
- 24.09 .0005 25.08 .0006 26.65 .0001 27.13 .0001 29.10 .0002 30.10 .0001 31.10 .0002 32.11 .0001
- 35.12 .0003 36.10 .0002 37.15 .0003 38.17 .0001))
-
-(define c-f3 '( .99 .0412 1.99 .0398 2.99 .1009 3.99 .0605 4.97 .0481 5.96 .0358 6.96 .0065
- 7.83 .0052 7.97 .0050 8.95 .0042 9.94 .0038 10.95 .0044 11.94 .0120 12.93 .0044 13.92 .0074
- 14.92 .0037 15.92 .0030 16.92 .0017 17.90 .0021 18.90 .0016 19.89 .0016 20.89 .0002 22.86 .0013
- 23.87 .0014 24.87 .0006 25.86 .0003 26.88 .0001 29.84 .0004 30.83 .0002 31.82 .0001 32.83 .0001
- 33.81 .0001 34.81 .0002 35.82 .0003 37.80 .0002))
-
-(define c-fs3 '( 1.00 .0386 2.00 .0915 3.00 .0406 4.01 .0601 5.00 .0460 5.99 .0213 7.01 .0148
- 8.00 .0085 9.00 .0073 10.00 .0017 11.01 .0191 12.00 .0069 13.00 .0057 14.02 .0023 15.01 .0059
- 16.00 .0010 17.02 .0006 18.01 .0019 19.00 .0012 20.02 .0002 20.99 .0004 22.01 .0013 23.02 .0007
- 24.02 .0002 24.94 .0001 27.03 .0001 28.02 .0002 29.00 .0001 31.01 .0001 32.01 .0001 33.02 .0003
- 34.03 .0002))
-
-(define c-g3 '( 1.01 .0124 1.99 .0359 2.98 .0602 3.98 .0390 4.98 .0496 5.98 .0070 6.98 .0121
- 7.97 .0089 8.97 .0044 9.97 .0068 10.97 .0085 11.96 .0110 12.95 .0034 13.95 .0099 14.95 .0059
- 15.95 .0003 16.94 .0014 17.94 .0005 18.94 .0008 19.95 .0004 20.94 .0007 21.39 .0001 22.95 .0002
- 24.93 .0001 25.92 .0002 27.91 .0001 29.91 .0005 30.94 .0001 31.93 .0002 33.90 .0001))
-
-(define c-gs3 '( 1.00 .0509 1.99 .1477 3.00 .0407 4.00 .0514 5.00 .0367 6.00 .0032 7.02 .0097
- 8.00 .0090 9.07 .0009 10.03 .0069 10.99 .0020 12.03 .0010 13.02 .0019 14.06 .0010 15.02 .0010
- 16.03 .0008 17.03 .0003 18.05 .0002 18.98 .0004 20.09 .0002 21.03 .0001 28.01 .0001))
-
-(define c-a3 '( 1.00 .0110 2.01 .0315 3.02 .1476 4.03 .0358 5.01 .0391 6.02 .0638 7.03 .0692
- 8.02 .0039 9.04 .0218 10.04 .0342 11.05 .0335 12.04 .0187 13.05 .0167 14.06 .0168 15.06 .0035
- 16.07 .0019 17.07 .0014 18.08 .0040 19.07 .0070 20.08 .0014 21.09 .0015 22.08 .0003 23.10 .0003
- 24.08 .0011 25.10 .0003 26.12 .0013 27.13 .0009 28.13 .0006 29.12 .0003 30.11 .0002 31.13 .0002
- 33.15 .0002 34.13 .0001 36.15 .0001 41.16 .0002 44.18 .0001 47.17 .0001))
-
-(define c-as3 '( 1.00 .0140 2.00 .0411 3.00 .0723 4.00 .1057 5.00 .0044 6.00 .0248 6.98 .0048
- 8.00 .0014 9.00 .0304 9.99 .0184 10.99 .0130 12.00 .0159 13.00 .0107 13.99 .0021 15.00 .0015
- 15.99 .0020 17.00 .0028 18.00 .0067 19.00 .0005 20.04 .0003 21.00 .0003 22.02 .0001 23.98 .0003
- 25.01 .0007 26.01 .0009 27.00 .0003 28.02 .0002 28.98 .0002 30.00 .0002 31.01 .0002 32.01 .0002
- 32.99 .0003 33.99 .0001 35.02 .0002 37.00 .0002 38.98 .0003 43.98 .0001 44.99 .0001))
-
-(define c-b3 '( 1.00 .0648 2.00 .0397 3.00 .0872 4.01 .0429 5.00 .0213 6.01 .0524 7.00 .0064
- 8.03 .0162 9.02 .0212 10.01 .0175 11.02 .0256 12.03 .0038 13.03 .0039 14.04 .0056 15.03 .0008
- 16.08 .0005 17.03 .0032 18.04 .0010 19.04 .0011 20.04 .0002 21.06 .0010 22.05 .0002 23.08 .0011
- 24.09 .0005 25.12 .0003 26.07 .0002 27.03 .0001 39.10 .0002))
-
-(define c-c4 '( 1.00 .0472 2.00 .1961 3.00 .1030 4.00 .0974 5.00 .0183 6.00 .0397 7.00 .0158
- 8.00 .0170 8.99 .0253 10.00 .0129 10.99 .0121 11.99 .0103 12.98 .0055 14.03 .0004 14.99 .0012
- 15.99 .0051 16.99 .0009 17.99 .0012 19.00 .0004 19.98 .0015 21.02 .0002 22.00 .0009 22.99 .0007
- 24.01 .0004 25.00 .0002 26.00 .0003 28.00 .0002 28.97 .0002 31.00 .0002 32.98 .0003 33.98 .0001
- 34.97 .0001 35.98 .0002 37.97 .0002 38.97 .0001))
-
-(define c-cs4 '( 1.00 .1199 2.00 .0345 3.01 .0978 4.00 .0466 5.02 .0070 6.01 .0258 7.02 .0241
- 8.01 .0070 9.02 .0161 10.02 .0124 11.02 .0145 12.02 .0101 13.02 .0026 14.03 .0011 15.02 .0028
- 16.03 .0011 17.04 .0005 18.02 .0003 19.05 .0012 20.07 .0004 21.06 .0011 22.06 .0007 23.04 .0007
- 24.05 .0005 26.07 .0003 27.04 .0002 28.05 .0002 29.06 .0001 32.05 .0001 33.06 .0002 35.07 .0002
- 36.07 .0001 37.07 .0002))
-
-(define c-d4 '( 1.00 .0657 2.00 .0681 3.00 .1031 3.99 .0157 4.99 .0570 5.98 .0160 6.99 .0236
- 7.98 .0259 8.99 .0144 9.98 .0154 10.98 .0046 11.97 .0104 12.98 .0024 13.97 .0020 14.97 .0012
- 15.97 .0010 16.97 .0004 17.95 .0008 18.97 .0005 19.98 .0007 20.98 .0009 21.93 .0004 22.00 .0003
- 22.94 .0002 23.95 .0002 24.98 .0001 25.97 .0002 26.96 .0001 28.94 .0002 29.94 .0002 30.94 .0002
- 32.97 .0001 33.97 .0001 34.95 .0001 36.93 .0001))
-
-(define c-ds4 '( 1.00 .3562 1.99 .0664 2.99 .1446 3.98 .0393 4.97 .0363 5.97 .0237 6.96 .0366
- 7.95 .0079 8.96 .0127 9.95 .0148 10.95 .0143 11.94 .0031 12.96 .0022 13.94 .0032 14.92 .0004
- 15.92 .0007 16.90 .0007 17.92 .0007 18.92 .0012 19.94 .0005 20.89 .0003 21.88 .0001 22.89 .0005
- 23.87 .0004 24.87 .0001 25.89 .0007 26.87 .0001 29.85 .0001 30.83 .0001 31.82 .0001 32.82 .0002
- 33.82 .0001))
-
-(define c-e4 '( 1.00 .0390 2.01 .1863 3.02 .0265 4.02 .0184 5.02 .0319 6.03 .0456 7.04 .0122
- 8.04 .0149 9.05 .0159 10.05 .0067 11.06 .0044 12.06 .0053 13.08 .0012 14.08 .0008 15.08 .0007
- 16.09 .0021 17.09 .0005 18.09 .0021 19.13 .0016 20.12 .0004 21.12 .0003 22.14 .0003 23.12 .0003
- 24.13 .0003 25.14 .0005 26.14 .0002 27.15 .0002 28.16 .0002 29.18 .0002 30.17 .0002 31.16 .0002
- 36.21 .0001))
-
-(define c-f4 '( 1.00 .1183 1.99 .1142 2.99 .1085 3.98 .0306 4.99 .0252 5.97 .0272 6.97 .0290
- 7.97 .0142 8.97 .0112 9.96 .0079 10.96 .0038 11.97 .0026 12.96 .0014 13.95 .0007 14.94 .0011
- 15.95 .0008 16.94 .0011 17.03 .0001 17.94 .0001 18.95 .0004 19.94 .0003 20.94 .0007 21.92 .0002
- 23.92 .0002 24.92 .0002 25.90 .0002 26.90 .0002 27.89 .0001 28.89 .0002 30.89 .0001))
-
-(define c-fs4 '( 1.00 .1140 2.00 .0935 3.00 .0504 3.99 .0715 4.99 .0063 6.00 .0808 6.99 .0099
- 8.00 .0093 9.00 .0093 9.99 .0019 10.99 .0050 11.99 .0017 12.99 .0021 14.00 .0003 14.99 .0010
- 16.00 .0015 17.00 .0019 17.95 .0002 18.00 .0002 18.99 .0002 19.99 .0003 21.00 .0002 21.99 .0003
- 23.99 .0001 24.98 .0001 26.02 .0001 27.01 .0001 28.00 .0002))
-
-(define c-g4 '( 1.00 .0809 1.99 .1377 2.99 .0348 3.99 .0337 4.98 .0177 5.98 .0295 6.98 .0266
- 7.98 .0063 8.98 .0105 9.97 .0016 10.97 .0022 11.98 .0029 12.97 .0018 13.96 .0008 14.99 .0023
- 15.97 .0012 16.96 .0009 17.97 .0002 18.95 .0006 20.94 .0002 20.99 .0002 22.95 .0002 23.94 .0002
- 24.94 .0003 25.97 .0003 26.95 .0002))
-
-(define c-gs4 '( 1.00 .2601 1.99 .1726 2.99 .0722 3.99 .0276 4.99 .0535 5.99 .0103 6.99 .0244
- 7.99 .0046 8.98 .0035 9.99 .0088 10.98 .0038 11.98 .0008 12.96 .0006 13.98 .0020 14.98 .0016
- 15.98 .0008 16.97 .0003 17.97 .0005 18.98 .0006 19.96 .0005 20.96 .0001 21.96 .0003 23.96 .0002
- 24.96 .0003 25.96 .0002))
-
-(define c-a4 '( .99 .0363 1.98 .2481 2.98 .0514 3.97 .0365 4.97 .0468 5.95 .0182 6.95 .0333
- 7.94 .0106 8.93 .0048 9.92 .0048 10.92 .0016 11.90 .0010 12.89 .0011 13.92 .0023 14.90 .0014
- 15.88 .0007 16.87 .0002 17.89 .0001 18.85 .0004 19.84 .0002 20.84 .0003 21.84 .0004 22.83 .0003
- 23.86 .0002 24.84 .0002 26.82 .0001))
-
-(define c-as4 '( .99 .0564 1.99 .1983 2.98 .0520 3.97 .0442 4.97 .0260 5.96 .0139 6.96 .0099
- 7.94 .0046 8.94 .0178 9.94 .0032 10.93 .0021 11.00 .0002 11.93 .0001 12.92 .0038 13.91 .0011
- 14.90 .0006 15.92 .0004 16.89 .0004 17.89 .0002 18.87 .0005 19.87 .0003 20.86 .0003 21.85 .0003
- 22.85 .0001 23.85 .0001 24.85 .0001 25.85 .0002 26.84 .0002))
-
-(define c-b4 '( .99 .0774 1.98 .1289 2.96 .1071 3.95 .0216 4.94 .0346 5.93 .0108 6.91 .0239
- 7.90 .0056 8.88 .0045 9.88 .0014 10.87 .0057 11.85 .0018 12.85 .0035 13.83 .0007 14.84 .0003
- 15.80 .0003 16.79 .0008 17.78 .0003 18.78 .0002 19.76 .0004 20.75 .0005 21.73 .0002 23.71 .0001
- 24.68 .0001))
-
-(define c-c5 '( .99 .4933 1.97 .1293 2.95 .0971 4.92 .0189 5.91 .0031 6.88 .0093 7.87 .0143
- 8.85 .0063 9.84 .0010 10.82 .0023 11.81 .0015 12.79 .0006 13.78 .0009 14.76 .0007 15.75 .0004
- 16.72 .0007 17.71 .0002 18.68 .0008 19.67 .0004 20.66 .0003))
-
-(define c-cs5 '( .99 .1576 1.99 .0760 2.98 .0560 3.97 .1172 4.96 .0433 5.96 .0029 6.95 .0079
- 7.95 .0058 8.93 .0025 9.93 .0014 10.93 .0054 11.92 .0005 12.92 .0004 13.90 .0009 14.90 .0015
- 15.89 .0003 16.87 .0002 17.87 .0004 18.87 .0002 19.86 .0002 20.86 .0002 21.86 .0003 22.85 .0002))
-
-(define c-d5 '( 1.01 .1243 2.02 .0648 3.03 .0586 4.04 .0543 5.05 .0183 6.07 .0046 7.08 .0080
- 8.09 .0027 9.10 .0053 10.12 .0036 11.14 .0014 12.14 .0004 13.16 .0004 14.15 .0007 15.17 .0005
- 17.20 .0006 18.22 .0002 19.22 .0002 21.24 .0001))
-
-(define c-ds5 '( 1.01 .1367 2.02 .0170 3.02 .0192 4.03 .0425 5.04 .0143 6.05 .0064 7.06 .0057
- 8.06 .0028 9.08 .0027 10.09 .0051 11.09 .0009 12.09 .0001 13.10 .0014 14.11 .0005 15.13 .0003
- 16.13 .0003 17.14 .0002 19.15 .0003 20.17 .0004 21.17 .0001))
-
-(define c-e5 '( 1.02 .2402 2.03 .0419 3.05 .1068 5.08 .0164 6.10 .0019 7.11 .0044 8.13 .0018
- 9.15 .0044 10.17 .0021 11.18 .0003 12.20 .0007 13.21 .0011 14.24 .0003 15.24 .0008 16.27 .0001
- 17.28 .0001 18.31 .0001))
-
-(define c-f5 '( 1.01 .1166 2.03 .0750 3.04 .0532 4.05 .0620 5.06 .0054 6.07 .0141 7.08 .0027
- 8.10 .0015 9.09 .0021 10.13 .0006 11.13 .0009 12.14 .0004 13.15 .0008 14.17 .0003 15.18 .0002
- 17.19 .0003 18.20 .0002))
-
-(define c-fs5 '( 1.00 .1595 2.00 .0985 3.01 .1045 4.01 .0147 5.01 .0078 6.01 .0016 7.01 .0020
- 8.02 .0007 9.02 .0015 10.03 .0008 11.03 .0006 12.02 .0004 13.02 .0009 14.03 .0006 15.02 .0005
- 16.03 .0002 17.04 .0001))
-
-(define c-g5 '( 1.00 .1740 1.99 .0431 2.99 .1899 3.99 .0201 4.98 .0009 5.98 .0031 6.98 .0055
- 7.97 .0051 8.97 .0007 9.96 .0007 10.95 .0006 11.95 .0009 12.95 .0008 13.96 .0002 14.94 .0001
- 15.95 .0002))
-
-(define c-gs5 '( 1.00 .1902 1.99 .0327 2.98 .0551 3.98 .0157 4.97 .0078 5.97 .0030 6.96 .0035
- 7.96 .0020 8.95 .0017 9.94 .0011 10.94 .0005 11.93 .0007 12.93 .0004 13.92 .0002 14.93 .0003))
-
-(define c-a5 '( .99 .4175 1.99 .0209 2.98 .0274 3.97 .0220 4.96 .0061 5.96 .0020 6.96 .0038
- 7.95 .0009 8.95 .0014 9.93 .0005 10.93 .0005 11.91 .0007 12.91 .0002 13.91 .0001 14.91 .0001))
-
-(define c-as5 '( 1.00 .4648 2.00 .0475 3.01 .1268 4.01 .0164 5.02 .0035 6.02 .0018 7.02 .0033
- 8.03 .0028 9.03 .0008 10.03 .0006 11.03 .0005 12.04 .0006 13.05 .0003 14.04 .0001))
-
-(define c-b5 '( 1.01 .2812 2.02 .1380 3.02 .0722 4.03 .0215 5.04 .0036 6.06 .0018 7.05 .0005
- 8.07 .0015 9.08 .0013 10.08 .0003 11.10 .0002 12.11 .0003 13.11 .0002))
-
-(define c-c6 '( 1.01 .2553 2.01 .1160 3.02 .0171 4.02 .0272 5.02 .0020 6.03 .0062 7.03 .0012
- 8.04 .0011 9.05 .0007 10.05 .0007 11.06 .0002 12.06 .0001 12.08 .0001))
-
-(define c-cs6 '( 1.01 .1045 2.02 .1220 3.04 .0220 4.05 .0094 5.06 .0021 6.07 .0031 7.09 .0018
- 8.10 .0020 9.11 .0014 10.12 .0003 11.13 .0006))
-
-(define c-d6 '( 1.00 .0653 1.99 .2499 2.99 .0334 3.98 .0098 4.98 .0091 5.98 .0007 6.97 .0011
- 7.97 .0008 8.96 .0042 9.96 .0003 10.95 .0004))
-
-(define c-ds6 '( .99 .0485 1.99 .1325 2.98 .0152 3.98 .0064 4.97 .0043 5.97 .0007 6.96 .0007
- 7.97 .0006 8.96 .0003 9.95 .0004))
-
-(define c-e6 '( 1.01 .1797 2.01 .0750 4.03 .0065 5.04 .0018 6.04 .0012 7.04 .0004 8.06 .0003
- 9.06 .0003))
-
-;;;
-;;;
-;;;
-;;;
-;;; clarinet?
-(define cl-d3 '( 1.01 .1722 2.00 .0056 2.99 .1609 3.99 .0333 5.00 .1157 5.99 .1149 6.98 .0079
- 7.98 .0620 8.99 .0601 9.99 .0104 10.98 .0134 11.97 .0122 12.99 .0058 13.98 .0110 14.98 .0029
- 15.97 .0045 16.98 .0023 17.98 .0010 18.97 .0016 19.96 .0021 20.96 .0008 21.97 .0021 22.96 .0001
- 23.96 .0012 24.95 .0003 25.97 .0002 26.96 .0003 27.95 .0002 30.96 .0002 32.94 .0002 34.96 .0001
- 35.95 .0002 37.93 .0001))
-
-(define cl-ds3 '( .99 .1038 1.98 .0043 2.96 .0953 3.97 .0013 4.94 .1057 5.93 .0145 6.93 .0787
- 7.91 .0328 8.89 .0086 9.90 .0088 10.88 .0128 11.86 .0005 12.86 .0085 13.84 .0026 14.83 .0051
- 15.81 .0030 16.82 .0008 17.79 .0026 18.78 .0013 19.78 .0015 20.76 .0011 22.74 .0012 23.72 .0002
- 24.71 .0006 25.70 .0003 26.70 .0002 28.67 .0002 30.64 .0002 31.64 .0001 32.63 .0001 33.61 .0003
- 35.59 .0002))
-
-(define cl-e3 '( 1.00 .0825 1.99 .0024 2.97 .0406 3.96 .0042 4.94 .0683 6.40 .0010 6.92 .0709
- 7.92 .0099 8.91 .0059 9.89 .0055 10.88 .0111 11.90 .0009 12.86 .0126 13.87 .0021 14.84 .0110
- 15.83 .0010 16.83 .0057 17.81 .0007 18.80 .0037 19.78 .0008 20.78 .0016 21.75 .0006 22.75 .0008
- 23.73 .0005 24.74 .0007 26.72 .0004 27.68 .0002 29.67 .0003 31.66 .0003 33.64 .0002))
-
-(define cl-f3 '( .99 .0685 1.98 .0012 2.98 .0854 3.98 .0029 4.96 .0507 5.97 .0017 6.96 .0507
- 7.94 .0027 8.94 .0092 9.94 .0084 10.92 .0116 11.91 .0018 12.92 .0039 13.92 .0003 14.89 .0013
- 15.88 .0019 16.87 .0012 17.86 .0010 18.87 .0011 19.86 .0008 20.85 .0008 21.83 .0002 23.81 .0004
- 24.83 .0002 25.80 .0003 27.78 .0002 29.78 .0001))
-
-(define cl-fs3 '( 1.00 .1546 1.99 .0015 2.99 .0594 4.00 .0014 5.00 .0268 6.00 .0019 7.00 .0170
- 7.97 .0005 9.00 .0110 9.99 .0006 10.99 .0077 11.99 .0013 12.99 .0025 14.01 .0004 14.99 .0018
- 15.98 .0001 16.98 .0013 17.97 .0003 18.98 .0013 20.97 .0001 21.97 .0004 22.96 .0002 23.98 .0002
- 25.99 .0001))
-
-(define cl-g3 '( .99 .1660 2.00 .0016 2.99 .0889 3.99 .0017 4.99 .0430 6.00 .0009 6.98 .0128
- 8.00 .0040 8.98 .0077 9.99 .0017 10.98 .0052 11.98 .0011 12.98 .0012 13.97 .0008 14.98 .0010
- 15.97 .0005 16.98 .0005 17.96 .0007 18.97 .0002 19.96 .0004 20.96 .0003 22.94 .0003 23.95 .0002
- 24.96 .0002 25.93 .0001 26.94 .0002 27.95 .0001))
-
-(define cl-gs3 '( 1.00 .1107 2.00 .0016 2.99 .0872 3.99 .0028 4.98 .0293 5.97 .0020 6.96 .0202
- 7.99 .0019 8.95 .0118 9.94 .0028 10.95 .0040 11.92 .0006 12.95 .0030 13.92 .0002 14.92 .0010
- 15.91 .0005 16.91 .0015 18.90 .0004 19.89 .0004 20.89 .0002 21.88 .0004 22.87 .0002 23.88 .0001
- 24.87 .0001))
-
-(define cl-a3 '( 1.00 .0842 2.01 .0017 3.00 .0420 4.01 .0029 5.00 .0251 6.02 .0041 6.99 .0115
- 7.96 .0006 8.99 .0032 9.98 .0003 11.00 .0018 11.96 .0003 12.96 .0006 14.00 .0001 14.97 .0001
- 15.97 .0005 17.95 .0002 18.96 .0001 19.07 .0001 22.06 .0001))
-
-(define cl-as3 '( 1.00 .1118 1.99 .0006 2.98 .0383 3.98 .0019 4.98 .0335 5.98 .0034 6.97 .0131
- 7.94 .0005 8.95 .0024 9.96 .0028 10.96 .0019 11.94 .0012 12.94 .0012 13.93 .0003 14.94 .0007
- 16.92 .0004 17.90 .0003 18.93 .0002 20.89 .0002 21.90 .0001))
-
-(define cl-b3 '( 1.00 .1324 1.99 .0011 3.00 .0693 4.01 .0012 4.99 .0279 5.98 .0044 6.98 .0149
- 7.97 .0009 8.97 .0028 9.97 .0009 10.98 .0026 11.96 .0003 12.96 .0006 13.95 .0003 15.95 .0001
- 16.94 .0001))
-
-(define cl-c4 '( 1.00 .2335 1.99 .0017 2.99 .1253 4.01 .0023 4.99 .0343 6.01 .0028 6.98 .0023
- 7.98 .0014 8.98 .0041 10.01 .0003 10.96 .0004 11.94 .0008 12.94 .0002 14.94 .0003 15.94 .0004
- 16.93 .0002 17.91 .0002 18.91 .0002 19.91 .0001 20.90 .0001))
-
-(define cl-cs4 '( .99 .2609 2.00 .0016 2.99 .1469 3.99 .0040 4.99 .0143 5.97 .0091 6.97 .0055
- 7.97 .0024 8.96 .0041 9.96 .0015 10.96 .0021 11.95 .0005 12.94 .0011 13.93 .0004 14.94 .0006
- 15.94 .0004 16.92 .0004 17.93 .0002 18.93 .0001 19.91 .0001 20.91 .0001 21.90 .0002 22.91 .0001))
-
-(define cl-d4 '( 1.00 .2056 1.99 .0006 2.99 .1715 3.99 .0010 4.98 .0194 5.99 .0028 6.98 .0106
- 7.98 .0007 8.97 .0022 9.97 .0005 10.96 .0011 11.97 .0006 12.96 .0006 13.96 .0003 14.95 .0005
- 15.95 .0003 17.95 .0002 18.94 .0002 20.94 .0001))
-
-(define cl-ds4 '( 1.00 .2590 1.98 .0019 2.99 .1336 3.97 .0034 4.97 .0442 5.97 .0017 6.96 .0108
- 7.96 .0006 8.95 .0031 9.94 .0003 11.93 .0003 12.93 .0004 13.93 .0005 14.92 .0001 15.91 .0003
- 16.90 .0004 17.90 .0002 18.89 .0001))
-
-(define cl-e4 '( 1.00 .2560 2.00 .0013 3.00 .0878 4.00 .0053 5.00 .0304 6.00 .0009 7.00 .0060
- 7.99 .0007 9.00 .0011 9.99 .0006 10.99 .0006 11.98 .0001 13.99 .0001))
-
-(define cl-f4 '( .99 .1966 1.99 .0021 2.98 .0812 3.96 .0018 4.97 .0248 5.96 .0032 6.96 .0060
- 7.95 .0024 8.95 .0019 9.94 .0008 10.94 .0007 11.92 .0005 12.91 .0002 13.94 .0001 14.90 .0002
- 15.91 .0002))
-
-(define cl-fs4 '( 1.00 .1555 2.01 .0022 3.01 .1755 4.01 .0005 5.01 .0127 6.02 .0004 7.02 .0031
- 8.02 .0007 9.02 .0005 10.02 .0002 11.03 .0003 12.02 .0002 14.02 .0001 15.03 .0001 16.04 .0001))
-
-(define cl-g4 '( 1.00 .0470 2.00 .0016 3.00 .0787 4.00 .0041 5.00 .0046 6.00 .0010 7.00 .0036
- 8.00 .0011 9.00 .0012 10.00 .0002 11.00 .0003 13.00 .0001))
-
-(define cl-gs4 '( 1.00 .1205 1.99 .0014 2.99 .0145 3.99 .0015 4.99 .0030 5.99 .0005 6.98 .0006
- 9.00 .0001 9.98 .0001))
-
-(define cl-a4 '( 1.00 .2677 2.00 .0592 3.01 .0961 4.01 .0083 5.02 .0075 6.02 .0027 7.03 .0048
- 8.03 .0031 9.02 .0007 10.03 .0003 11.03 .0001))
-
-(define cl-as4 '( 1.00 .1363 2.01 .0056 3.00 .0168 4.01 .0026 5.01 .0112 6.00 .0011 7.01 .0011
- 8.01 .0003 10.00 .0002 12.02 .0001))
-
-(define cl-b4 '( 1.01 .0312 2.01 .0042 3.02 .0061 4.02 .0127 5.03 .0090 6.04 .0002 7.04 .0021
- 8.05 .0008 11.06 .0001))
-
-(define cl-c5 '( 1.00 .2597 2.00 .0052 3.00 .0337 4.00 .0012 5.00 .0025 6.00 .0014 7.00 .0007
- 7.99 .0004 8.99 .0003 10.00 .0004))
-
-(define cl-cs5 '( 1.00 .1894 2.00 .0060 3.00 .0250 4.01 .0022 5.01 .0048 6.00 .0004 8.01 .0001
- 10.01 .0001))
-
-(define cl-d5 '( 1.00 .1727 2.01 .0013 3.00 .0066 4.01 .0011 5.00 .0013 5.99 .0008 8.02 .0001))
-
-(define cl-ds5 '( 1.00 .3538 2.00 .0053 3.01 .0757 4.01 .0009 5.01 .0045 6.02 .0008 7.02 .0011
- 8.01 .0003 9.02 .0005 10.01 .0002 11.02 .0001 12.02 .0002))
-
-(define cl-e5 '( 1.00 .1647 2.00 .0048 3.00 .0524 3.99 .0055 4.99 .0030 5.98 .0011 6.99 .0004
- 7.99 .0003))
-
-(define cl-f5 '( .99 .1880 1.99 .0126 2.99 .0222 3.98 .0070 4.98 .0135 5.97 .0020 6.97 .0012
- 7.96 .0001 8.96 .0007 9.95 .0003))
-
-(define cl-fs5 '( 1.00 .3103 2.00 .0104 3.00 .0335 4.00 .0078 5.00 .0026 6.01 .0005 7.01 .0006
- 8.00 .0003))
-
-(define cl-g5 '( 1.01 .4163 2.01 .0446 3.02 .0290 4.03 .0031 5.02 .0004 6.03 .0002 7.05 .0001
- 8.05 .0001))
-
-(define cl-gs5 '( 1.01 .2150 2.00 .0334 3.00 .0012 4.02 .0003 5.02 .0002))
-
-(define cl-a5 '( 1.01 .5463 2.01 .0429 3.02 .0317 4.02 .0159 5.03 .0012 6.04 .0005 7.04 .0005
- 8.05 .0002))
-
-(define cl-as5 '( 1.00 .3802 2.00 .0397 3.01 .0186 4.01 .0102 5.01 .0020 6.01 .0001 7.01 .0002
- 8.02 .0003 9.02 .0002 10.02 .0001 11.02 .0001 12.02 .0002))
-
-(define cl-b5 '( 1.00 .0896 2.00 .0851 3.00 .0081 4.00 .0024 5.00 .0010 6.00 .0001 7.00 .0002))
-
-(define cl-c6 '( 1.00 .1740 2.00 .0081 3.01 .0111 4.01 .0087 5.01 .0005 6.01 .0007 7.01 .0001
- 9.01 .0002 10.02 .0002))
-
-(define cl-cs6 '( 1.00 .1295 1.99 .0270 2.99 .0012 3.99 .0004))
-
-(define cl-d6 '( 1.00 .1700 2.01 .0603 3.01 .0169 4.01 .0031 5.01 .0007 6.01 .0002))
-
-(define cl-ds6 '( 1.01 .2624 2.02 .0042 3.03 .0049 4.03 .0015 5.04 .0001))
-
-(define cl-e6 '( 1.02 .0632 2.03 .0115 3.04 .0011 4.06 .0006))
-
-(define cl-f6 '( 1.02 .0748 2.03 .0535 3.05 .0044 4.07 .0009 5.08 .0001 7.12 .0001 8.13 .0001))
-
-(define cl-fs6 '( 1.02 .0305 2.03 .0175 3.04 .0005 4.05 .0002))
-
-(define cl-g6 '( 1.03 .0026 2.04 .0008))
-
-(define cl-gs6 '( 1.03 .0015 2.00 .0002))
-
-(define cl-a6 '( 1.03 .0043 2.05 .0010))
-
-(define cl-as6 '( 1.05 .0008 2.00 .0001))
-
-
-;;;
-;;;
-;;;
-;;;
-;;; french horn?
-(define fh-as1 '( 1.01 .0041 2.00 .0015 3.01 .0121 4.02 .0111 5.02 .0343 6.03 .0165 7.04 .0066
- 8.03 .0064 9.05 .0049 10.06 .0012 11.05 .0093 12.07 .0029 13.07 .0042 14.08 .0040 15.08 .0019
- 16.09 .0013 17.10 .0009 18.04 .0002 19.03 .0002 20.12 .0003 21.13 .0003 22.13 .0002 23.13 .0002))
-
-(define fh-b1 '( 1.01 .0035 2.03 .0064 3.04 .0087 4.08 .0087 5.12 .0049 6.08 .0189 7.10 .0304
- 8.12 .0205 9.16 .0026 10.18 .0039 11.20 .0006 12.11 .0029 13.15 .0037 14.24 .0014 15.26 .0010
- 16.29 .0005 17.19 .0003 18.21 .0007 19.23 .0005 20.25 .0004 21.33 .0003 22.36 .0001 23.32 .0002
- 24.33 .0002 25.33 .0001 26.39 .0002 27.42 .0002))
-
-(define fh-c2 '( 1.02 .0034 2.02 .0059 3.01 .0083 4.02 .0274 5.03 .0206 6.03 .0155 7.04 .0131
- 8.03 .0073 9.05 .0014 10.03 .0064 11.05 .0055 12.06 .0109 13.08 .0037 14.10 .0012 15.10 .0010
- 16.01 .0004 17.05 .0009 18.06 .0008 19.06 .0006 20.09 .0004 21.11 .0002 22.14 .0002 23.09 .0002
- 24.08 .0001 25.08 .0002 26.07 .0002 27.12 .0002 28.16 .0001 32.11 .0001))
-
-(define fh-cs2 '( 1.01 .0038 1.99 .0124 2.98 .0065 4.00 .0260 5.00 .0138 5.99 .0093 6.97 .0077
- 7.95 .0055 8.97 .0061 9.97 .0016 10.95 .0034 11.96 .0036 12.14 .0010 12.94 .0009 13.97 .0008
- 14.86 .0004 15.89 .0006 16.91 .0007 17.93 .0004 18.94 .0002 19.95 .0001 20.77 .0001 21.78 .0002
- 22.86 .0001 23.89 .0002))
-
-(define fh-d2 '( 1.01 .0153 2.01 .0192 3.01 .0216 4.01 .0371 5.01 .0259 6.02 .0188 7.02 .0076
- 8.04 .0009 9.03 .0038 10.03 .0065 11.03 .0075 12.03 .0026 13.03 .0005 14.04 .0009 15.06 .0008
- 16.04 .0006 17.03 .0004 18.03 .0003 19.04 .0002 23.03 .0002))
-
-(define fh-ds2 '( 1.00 .0234 1.98 .0227 2.96 .0129 3.97 .0333 4.96 .0315 5.95 .0252 6.93 .0076
- 7.94 .0061 8.91 .0028 9.89 .0096 10.90 .0089 11.89 .0024 12.88 .0022 13.88 .0019 14.87 .0010
- 15.79 .0006 16.79 .0003 17.79 .0002 18.69 .0002 19.68 .0003 20.70 .0002 21.70 .0002))
-
-(define fh-e2 '( 1.00 .0150 1.99 .0230 3.01 .0204 4.00 .0298 5.02 .0112 6.03 .0135 7.02 .0019
- 8.03 .0061 9.01 .0099 10.04 .0053 11.03 .0006 12.04 .0028 13.04 .0016 14.04 .0015 15.03 .0009
- 16.02 .0005 17.05 .0002 20.02 .0002 21.02 .0001 24.00 .0002 25.03 .0001))
-
-(define fh-f2 '( .97 .0088 1.96 .0127 2.97 .0179 3.96 .0163 4.94 .0421 5.91 .0165 6.96 .0019
- 7.93 .0020 8.91 .0112 9.85 .0035 10.91 .0017 12.02 .0004 12.83 .0014 13.79 .0010 14.79 .0007
- 15.75 .0002 16.73 .0003 17.74 .0007 18.74 .0005 19.73 .0001 20.68 .0002 21.66 .0002 22.65 .0002
- 23.63 .0001 24.65 .0001))
-
-(define fh-fs2 '( 1.00 .0035 1.99 .0136 2.97 .0394 3.96 .0379 4.98 .0330 5.97 .0111 6.94 .0156
- 7.94 .0108 8.96 .0076 9.95 .0025 10.95 .0021 11.93 .0026 12.93 .0014 13.89 .0008 14.87 .0006
- 15.78 .0001 16.94 .0001 17.93 .0001 18.93 .0001 19.89 .0001))
-
-(define fh-g2 '( 1.01 .0150 2.01 .0182 3.04 .1047 4.04 .0662 5.03 .0448 6.06 .0018 7.06 .0034
- 8.06 .0202 9.09 .0051 10.09 .0070 11.08 .0060 12.11 .0022 13.12 .0011 14.13 .0005 15.20 .0001
- 16.09 .0002 17.14 .0002 18.14 .0002 19.14 .0002 20.16 .0002 21.15 .0001 22.15 .0001))
-
-(define fh-gs2 '( .99 .0092 2.00 .0177 3.00 .0664 3.98 .0447 4.99 .0223 5.99 .0144 7.00 .0124
- 7.97 .0096 8.97 .0046 9.96 .0011 10.99 .0021 12.00 .0010 12.99 .0007 13.93 .0007 14.92 .0007
- 15.94 .0005 16.94 .0003 17.90 .0002 18.88 .0001 19.87 .0002 20.86 .0002 21.86 .0001))
-
-(define fh-a2 '( 1.00 .0063 2.01 .0609 3.03 .0699 4.05 .1365 5.04 .0249 6.05 .0103 7.07 .0200
- 8.08 .0059 9.10 .0063 10.09 .0046 11.10 .0015 12.13 .0008 13.14 .0006 14.07 .0004 15.05 .0004
- 16.08 .0004 17.10 .0002 18.12 .0002 19.10 .0001))
-
-(define fh-as2 '( 1.00 .0026 2.02 .0329 3.03 .0926 4.04 .0530 5.07 .0041 6.07 .0072 7.09 .0076
- 8.10 .0053 9.11 .0057 10.13 .0017 11.16 .0005 12.21 .0001 13.09 .0003 14.11 .0003 15.18 .0003
- 16.17 .0001))
-
-(define fh-b2 '( 1.01 .0154 2.02 .0506 3.05 .1042 4.05 .0643 5.06 .0151 6.08 .0102 7.09 .0045
- 8.11 .0040 9.12 .0033 10.12 .0015 11.13 .0006 12.16 .0004 13.18 .0003 14.95 .0001 15.98 .0001
- 16.99 .0001 18.02 .0001))
-
-(define fh-c3 '( 1.01 .0147 2.02 .0897 3.01 .1180 4.01 .0323 5.02 .0133 6.04 .0226 7.04 .0033
- 8.06 .0023 9.02 .0019 10.03 .0010 11.04 .0009 12.06 .0003 13.04 .0002 14.05 .0002 15.05 .0002
- 16.01 .0002 16.94 .0001))
-
-(define fh-cs3 '( 1.01 .0345 2.00 .1083 2.99 .0911 4.01 .0280 5.01 .0071 6.00 .0123 7.00 .0043
- 8.01 .0034 9.01 .0014 10.02 .0004 10.94 .0003 11.96 .0003 12.96 .0002 14.89 .0001 15.92 .0001))
-
-(define fh-d3 '( 1.01 .0488 2.02 .1313 3.03 .1606 4.03 .0029 5.04 .0187 6.05 .0059 7.05 .0018
- 8.05 .0023 9.05 .0007 10.06 .0003 11.07 .0001 12.08 .0002))
-
-(define fh-ds3 '( 1.00 .0619 2.00 .1230 3.01 .0981 4.02 .0299 5.02 .0210 6.03 .0054 7.03 .0023
- 8.04 .0010 9.04 .0005 10.06 .0002))
-
-(define fh-e3 '( 1.00 .0500 2.01 .1076 3.03 .1077 4.04 .0167 5.03 .0138 6.06 .0058 7.07 .0036
- 8.06 .0007 9.09 .0004 10.07 .0002 11.03 .0001 12.05 .0002))
-
-(define fh-f3 '( 1.01 .0368 2.02 .1311 3.02 .0405 4.03 .0139 5.03 .0080 6.04 .0052 7.05 .0015
- 8.04 .0004 9.06 .0002 10.06 .0002 12.08 .0001))
-
-(define fh-fs3 '( 1.01 .0430 2.02 .1877 3.05 .0299 4.05 .0218 5.07 .0067 6.08 .0054 7.10 .0012
- 8.11 .0010 9.12 .0004 10.13 .0002 11.15 .0001))
-
-(define fh-g3 '( 1.01 .0339 2.04 .1965 4.07 .0541 5.08 .0113 6.10 .0049 7.10 .0022 8.13 .0014
- 9.14 .0008 10.16 .0005))
-
-(define fh-gs3 '( 1.02 .0596 2.02 .1865 3.03 .0629 4.04 .0304 5.05 .0087 6.05 .0035 7.07 .0008
- 8.09 .0004 9.09 .0005 10.10 .0005 11.11 .0002 12.12 .0001))
-
-(define fh-a3 '( 1.00 .1160 2.02 .2642 3.02 .0259 4.02 .0127 5.04 .0095 6.04 .0022 7.04 .0013
- 8.06 .0008 9.04 .0003 10.01 .0001))
-
-(define fh-as3 '( 1.01 .0585 2.01 .1648 3.02 .0229 4.02 .0150 5.03 .0084 6.03 .0016 7.06 .0003
- 9.01 .0002))
-
-(define fh-b3 '( 1.01 .0741 2.00 .1581 3.00 .0490 4.01 .0133 5.01 .0045 6.02 .0013 7.03 .0002
- 8.00 .0001))
-
-(define fh-c4 '( .99 .1378 2.00 .0872 2.99 .0736 3.99 .0065 4.99 .0025 5.97 .0009 6.98 .0002
- 7.98 .0005 8.98 .0002))
-
-(define fh-cs4 '( 1.01 .2826 2.02 .0676 3.02 .0523 4.03 .0208 5.04 .0069 6.04 .0009 7.05 .0009
- 8.06 .0011 9.07 .0004 10.07 .0001 11.08 .0002 12.09 .0001))
-
-(define fh-d4 '( 1.01 .2849 2.02 .0068 3.03 .0144 4.04 .0066 5.05 .0032 6.07 .0007 7.07 .0003
- 8.09 .0003))
-
-(define fh-ds4 '( 1.00 .2321 2.01 .0612 3.02 .0150 4.03 .0042 5.03 .0007 6.04 .0005 7.05 .0002
- 8.06 .0001))
-
-(define fh-e4 '( 1.01 .1701 2.01 .0303 3.02 .0156 4.03 .0021 5.04 .0009 6.04 .0003 7.04 .0001))
-
-(define fh-f4 '( 1.01 .1957 2.01 .0196 3.01 .0087 4.01 .0022 5.01 .0006 6.02 .0002))
-
-(define fh-fs4 '( 1.01 .3622 2.02 .0601 3.03 .0187 4.04 .0043 5.05 .0011 6.06 .0005))
-
-(define fh-g4 '( 1.00 .2782 2.01 .0918 3.01 .0080 4.03 .0013 5.03 .0010 6.03 .0003))
-
-(define fh-gs4 '( 1.01 .2703 2.02 .0548 3.02 .0083 4.03 .0011 5.03 .0009 6.04 .0003))
-
-(define fh-a4 '( 1.01 .4575 2.02 .0245 3.03 .0049 4.04 .0019 5.05 .0008 6.06 .0002))
-
-(define fh-as4 '( 1.00 .2524 2.01 .0291 3.02 .0022 4.03 .0011 5.03 .0003))
-
-(define fh-b4 '( 1.00 .3254 2.00 .0428 3.00 .0026 4.00 .0006))
-
-(define fh-c5 '( 1.00 .1672 2.00 .0223 3.00 .0010 4.00 .0005))
-
-(define fh-cs5 '( 1.00 .1209 2.00 .0340 3.00 .0014 4.01 .0004))
-
-(define fh-d5 '( 1.01 .0150 2.01 .0313 3.02 .0023 4.03 .0007))
-
-(define fh-ds5 '( 1.00 .1633 2.00 .0260 3.00 .0012 4.00 .0002))
-
-(define fh-e5 '( 1.00 .1001 2.00 .0146 3.00 .0019 4.00 .0001))
-
-(define fh-f5 '( 1.01 .0944 2.01 .0114 3.02 .0016 4.02 .0002))
-
-(define fh-fs5 '( 1.01 .1904 2.02 .0076 3.02 .0025 4.03 .0003))
-
-(define fh-g5 '( 1.00 .2511 2.00 .0017 3.01 .0010 4.01 .0004))
-
-(define fh-gs5 '( 1.00 .1029 1.99 .0050 2.99 .0007 3.99 .0002))
-
-
-;;;
-;;;
-;;;
-;;;
-;;;
-(define fhf-as1 '( 1.01 .0025 1.99 .0008 3.01 .0057 4.02 .0063 5.03 .0268 6.04 .0198 7.04 .0157
- 8.03 .0160 9.05 .0056 10.05 .0016 11.06 .0059 12.09 .0009 13.10 .0023 14.08 .0022 15.09 .0011
- 16.10 .0011 17.11 .0012 18.16 .0009 19.16 .0008 20.15 .0005 21.16 .0002 22.15 .0001 23.15 .0001))
-
-(define fhf-b1 '( 1.03 .0025 2.07 .0054 5.15 .0276 6.18 .0379 7.21 .0389 8.23 .0176 9.26 .0020
- 10.29 .0039 11.24 .0002 12.26 .0010 13.28 .0015 14.34 .0010 15.37 .0009 16.42 .0010 17.47 .0027
- 18.49 .0015 19.52 .0010 20.56 .0005 21.57 .0004 22.59 .0004 23.60 .0003 24.61 .0003 25.65 .0002
- 26.67 .0002 27.66 .0001 28.71 .0002 29.75 .0001))
-
-(define fhf-c2 '( 1.02 .0023 2.03 .0041 3.03 .0059 4.05 .0291 5.05 .0280 6.06 .0396 7.06 .0428
- 8.07 .0111 9.08 .0018 10.10 .0049 11.12 .0052 12.12 .0075 13.12 .0021 14.15 .0009 15.18 .0008
- 16.21 .0009 17.22 .0012 18.23 .0008 19.23 .0003 20.24 .0003 21.23 .0002 22.22 .0002 23.22 .0002
- 24.25 .0001 25.27 .0002 26.27 .0001 28.25 .0001 30.29 .0001 32.31 .0001))
-
-(define fhf-cs2 '( 1.03 .0031 2.02 .0111 3.02 .0074 4.01 .0370 5.01 .0307 6.03 .0330 7.03 .0281
- 8.02 .0089 9.02 .0097 9.21 .0016 10.03 .0014 11.04 .0044 12.03 .0039 12.96 .0004 14.09 .0011
- 15.10 .0006 16.10 .0014 17.09 .0011 18.09 .0006 19.10 .0005 20.10 .0004 21.08 .0002 22.10 .0003
- 22.28 .0002 23.07 .0001 24.04 .0002 25.09 .0001 26.10 .0001 27.10 .0001 32.10 .0001))
-
-(define fhf-d2 '( 1.00 .0154 2.01 .0193 3.01 .0257 4.00 .0566 5.00 .0570 6.01 .0680 7.01 .0222
- 8.03 .0023 9.02 .0036 10.05 .0043 11.07 .0037 12.07 .0010 12.97 .0005 13.99 .0014 14.99 .0022
- 15.98 .0023 16.97 .0011 17.96 .0007 18.95 .0004 19.12 .0003 19.89 .0002 20.92 .0003 21.11 .0002
- 21.92 .0002 22.91 .0002 23.88 .0002 24.92 .0002 25.89 .0003 26.88 .0003 27.84 .0001))
-
-(define fhf-ds2 '( 1.00 .0204 2.02 .0234 3.03 .0132 4.04 .0416 5.05 .0425 6.04 .0258 7.06 .0086
- 8.07 .0067 9.14 .0009 10.17 .0030 11.20 .0008 12.09 .0016 13.11 .0015 14.12 .0029 15.11 .0028
- 16.11 .0011 17.11 .0006 18.09 .0003 19.13 .0004 19.29 .0002 20.10 .0002 21.13 .0002 21.29 .0002
- 22.26 .0001 23.11 .0003 24.11 .0003 25.08 .0002 26.10 .0002 27.08 .0002 28.10 .0001 28.28 .0001))
-
-(define fhf-e2 '( 1.00 .0097 1.99 .0146 3.00 .0159 4.00 .0246 5.02 .0137 6.06 .0177 7.02 .0017
- 8.05 .0029 9.04 .0058 10.06 .0041 10.96 .0009 12.03 .0029 13.08 .0021 14.12 .0008 15.14 .0002
- 16.11 .0002 26.90 .0001))
-
-(define fhf-f2 '( 1.00 .0039 2.02 .0070 3.04 .0156 4.06 .0113 5.08 .0222 6.07 .0065 7.07 .0046
- 8.12 .0018 9.13 .0081 10.13 .0014 11.17 .0012 12.17 .0014 13.21 .0007 13.98 .0005 14.24 .0003
- 14.98 .0003 15.96 .0002 17.21 .0001 18.97 .0002 20.02 .0001 21.05 .0001))
-
-(define fhf-fs2 '( 1.02 .0030 2.03 .0096 3.04 .0372 4.06 .0225 5.09 .0048 6.17 .0019 7.19 .0014
- 8.20 .0014 9.19 .0023 10.22 .0008 11.09 .0003 12.23 .0006 13.25 .0004 14.25 .0002 15.14 .0001
- 16.19 .0002 17.20 .0002 18.24 .0002 19.23 .0001 20.27 .0001 21.29 .0001 23.26 .0001))
-
-(define fhf-g2 '( 1.03 .0067 2.02 .0055 3.06 .0282 5.01 .0043 5.20 .0033 6.05 .0006 7.09 .0009
- 8.13 .0070 9.17 .0006 10.20 .0010 11.23 .0007 12.28 .0002 13.16 .0001 14.23 .0001))
-
-(define fhf-gs2 '( .99 .0029 2.02 .0054 3.01 .0149 4.03 .0101 5.03 .0047 6.02 .0035 7.02 .0028
- 8.04 .0026 9.03 .0010 10.03 .0003 11.07 .0004 11.89 .0001 12.98 .0001 13.99 .0002))
-
-(define fhf-a2 '( .99 .0020 2.00 .0131 3.00 .0085 4.01 .0199 4.99 .0044 5.98 .0020 7.00 .0029
- 8.01 .0009 9.02 .0010 9.99 .0007 10.94 .0003))
-
-(define fhf-as2 '( 1.00 .0013 2.01 .0042 3.01 .0101 3.99 .0132 4.98 .0011 5.97 .0007 6.96 .0031
- 7.99 .0009 9.10 .0003 9.99 .0003 10.92 .0002 11.88 .0002 12.85 .0001))
-
-(define fhf-b2 '( 1.01 .0038 2.00 .0081 2.98 .0138 3.96 .0105 4.96 .0021 5.95 .0034 6.89 .0013
- 7.91 .0006 8.86 .0005 9.87 .0001))
-
-(define fhf-c3 '( 1.00 .0033 2.01 .0162 3.00 .0168 4.00 .0069 5.00 .0033 6.01 .0061 7.01 .0006
- 8.01 .0003 8.98 .0003 9.97 .0002 10.98 .0001))
-
-(define fhf-cs3 '( 1.01 .0161 2.01 .0404 3.01 .0208 4.02 .0039 5.02 .0013 6.02 .0041 7.02 .0019
- 8.01 .0011 9.01 .0003))
-
-(define fhf-d3 '( 1.01 .0238 2.01 .0582 3.02 .0679 4.02 .0022 5.03 .0081 6.03 .0024 7.03 .0012
- 8.05 .0010 9.05 .0001 10.08 .0001))
-
-(define fhf-ds3 '( 1.00 .0295 2.01 .0519 3.02 .0343 4.04 .0119 5.05 .0067 6.07 .0011 7.08 .0013
- 8.09 .0004))
-
-(define fhf-e3 '( 1.01 .0251 2.04 .0479 3.03 .0741 4.04 .0054 5.05 .0049 6.04 .0029 7.06 .0021
- 8.10 .0006 9.11 .0004 10.10 .0002 11.13 .0002))
-
-(define fhf-f3 '( 1.02 .0143 2.02 .0453 3.04 .0115 4.05 .0021 5.08 .0007 6.10 .0007 7.07 .0006
- 8.04 .0001))
-
-(define fhf-fs3 '( 1.01 .0220 2.03 .0843 3.04 .0119 4.06 .0062 5.09 .0022 6.12 .0016 7.14 .0003
- 9.13 .0001))
-
-(define fhf-g3 '( 1.02 .0145 2.03 .0700 3.03 .0010 5.13 .0013 6.14 .0007 7.14 .0002))
-
-(define fhf-gs3 '( 1.02 .0273 2.03 .0703 3.04 .0176 4.07 .0073 5.08 .0021 6.09 .0004 7.09 .0002
- 8.09 .0001))
-
-(define fhf-a3 '( 1.00 .0529 2.02 .0982 3.02 .0066 4.04 .0034 5.05 .0029 6.04 .0003 7.03 .0002))
-
-(define fhf-as3 '( 1.01 .0274 2.01 .0613 3.02 .0056 4.03 .0056 5.03 .0024 6.03 .0003))
-
-(define fhf-b3 '( 1.01 .0468 2.01 .0884 3.01 .0246 4.02 .0058 5.03 .0016 6.03 .0005 7.02 .0002
- 8.01 .0001))
-
-(define fhf-c4 '( 1.01 .0972 2.01 .0455 3.02 .0442 4.03 .0073 5.03 .0017 6.03 .0005 7.04 .0008
- 8.05 .0003 9.05 .0001))
-
-(define fhf-cs4 '( 1.01 .1452 2.01 .0382 3.02 .0285 4.02 .0080 5.02 .0019 6.01 .0002 7.03 .0003
- 8.04 .0002))
-
-(define fhf-d4 '( 1.01 .1930 2.02 .0066 3.03 .0070 4.05 .0041 5.05 .0016 6.07 .0003))
-
-(define fhf-ds4 '( 1.00 .1433 2.01 .0414 3.02 .0101 4.03 .0020 5.02 .0002 6.03 .0003 7.06 .0001))
-
-(define fhf-e4 '( 1.00 .1373 2.01 .0256 3.01 .0164 4.02 .0026 5.02 .0014 6.02 .0004 7.03 .0002))
-
-(define fhf-f4 '( 1.01 .1930 2.01 .0192 3.02 .0124 4.02 .0030 5.03 .0013 6.03 .0006 7.03 .0002))
-
-(define fhf-fs4 '( 1.01 .2352 2.01 .0485 3.02 .0135 4.03 .0035 5.03 .0010 6.04 .0004))
-
-(define fhf-g4 '( 1.01 .1991 2.03 .0655 3.04 .0065 4.04 .0015 5.06 .0006 6.07 .0002))
-
-(define fhf-gs4 '( 1.01 .2177 2.02 .0422 3.03 .0038 4.05 .0014 5.06 .0006))
-
-(define fhf-a4 '( 1.01 .3779 2.02 .0161 3.03 .0026 4.04 .0009 5.05 .0005))
-
-(define fhf-as4 '( 1.00 .1879 2.01 .0205 3.02 .0006 4.03 .0006))
-
-(define fhf-b4 '( .99 .2910 1.99 .0363 2.99 .0019 3.99 .0001 4.98 .0001))
-
-(define fhf-c5 '( 1.00 .0690 2.01 .0086 3.01 .0002 4.00 .0002))
-
-(define fhf-cs5 '( 1.01 .0872 2.02 .0247 3.03 .0008 4.05 .0002))
-
-(define fhf-d5 '( 1.01 .0213 2.02 .0275 3.03 .0031 4.04 .0008 5.05 .0002 6.07 .0001))
-
-(define fhf-ds5 '( 1.01 .1852 2.01 .0224 3.01 .0043 4.02 .0006 5.03 .0001))
-
-(define fhf-e5 '( 1.01 .1063 2.02 .0144 3.03 .0018 4.04 .0006 5.05 .0001))
-
-(define fhf-f5 '( 1.02 .1058 2.04 .0062 3.06 .0023 4.08 .0005))
-
-(define fhf-fs5 '( 1.01 .1683 2.03 .0099 3.04 .0026 4.05 .0004 5.07 .0003))
-
-(define fhf-g5 '( 1.01 .3271 2.02 .0090 3.03 .0022 4.04 .0007))
-
-;;;
-;;;
-;;;
-;;;
-;;; flute?
-(define fl-c4 '( 1.01 .0602 2.02 .0954 3.03 .0270 4.03 .0199 5.05 .0177 6.06 .0104 7.07 .0040
- 8.08 .0040 9.08 .0035 10.10 .0017 11.10 .0009 12.12 .0004 13.11 .0002 14.13 .0006 15.14 .0003
- 17.15 .0002 18.16 .0001))
-
-(define fl-cs4 '( 1.01 .0672 2.01 .0689 3.02 .0604 4.02 .0410 5.02 .0130 6.03 .0040 7.03 .0210
- 8.03 .0078 9.04 .0010 10.07 .0002 11.05 .0005 12.05 .0008 13.05 .0004 14.06 .0002 15.07 .0001
- 19.08 .0001))
-
-(define fl-d4 '( 1.01 .0747 2.01 .2106 3.01 .0522 4.02 .0208 5.01 .0138 6.02 .0024 7.03 .0071
- 8.03 .0038 8.17 .0002 8.74 .0001 10.03 .0004 11.04 .0014 12.03 .0001 13.06 .0002 14.05 .0003
- 15.06 .0001 16.07 .0001 17.06 .0002 18.06 .0002))
-
-(define fl-ds4 '( 1.00 .0256 2.00 .1167 3.00 .0241 4.01 .0159 5.01 .0200 6.00 .0167 7.01 .0069
- 8.04 .0004 9.00 .0009 10.01 .0010 11.00 .0004 12.00 .0003 13.00 .0002 14.01 .0002 16.00 .0002
- 17.01 .0002))
-
-(define fl-e4 '( 1.00 .0572 2.01 .1769 3.01 .0622 4.00 .0323 5.01 .0210 6.01 .0163 7.02 .0068
- 8.01 .0007 8.13 .0002 8.39 .0001 10.02 .0011 11.02 .0004 12.02 .0003 15.03 .0002 16.03 .0001
- 17.04 .0001 18.04 .0001))
-
-(define fl-f4 '( 1.01 .0438 2.01 .0964 3.01 .0569 4.01 .0096 5.01 .0164 6.01 .0194 7.02 .0024
- 8.01 .0005 9.03 .0007 10.04 .0005 12.05 .0002 13.04 .0001 14.05 .0002))
-
-(define fl-fs4 '( 1.00 .0952 2.00 .1432 3.01 .0299 4.01 .0371 5.02 .0189 6.02 .0092 7.03 .0060
- 8.03 .0003 9.04 .0025 10.04 .0006 11.04 .0003 13.05 .0002 14.06 .0002))
-
-(define fl-g4 '( 1.00 .2831 2.01 .1781 3.01 .0370 4.02 .0191 5.02 .0313 6.02 .0048 7.04 .0007
- 8.03 .0022 9.04 .0015 9.13 .0001 10.04 .0001 11.05 .0002 12.05 .0002 14.07 .0001 15.06 .0001))
-
-(define fl-gs4 '( 1.00 .2598 2.00 .2241 3.01 .0407 4.01 .0354 5.01 .0398 6.01 .0111 7.03 .0007
- 8.01 .0030 9.01 .0018 10.02 .0002 12.02 .0004 13.02 .0001 14.03 .0002 15.03 .0001))
-
-(define fl-a4 '( 1.00 .2580 2.01 .1605 3.00 .0236 4.01 .0281 5.02 .0047 6.02 .0024 7.02 .0010
- 8.02 .0027 9.02 .0004 10.03 .0002 11.03 .0003 12.04 .0001 13.04 .0002 14.04 .0002))
-
-(define fl-as4 '( 1.01 .1855 2.01 .1041 3.01 .0480 4.02 .0416 5.02 .0059 6.02 .0016 7.03 .0004
- 8.03 .0016 9.03 .0003 10.04 .0004 11.05 .0003 16.07 .0002))
-
-(define fl-b4 '( 1.01 .0564 2.01 .1996 3.02 .0219 4.02 .0108 5.03 .0183 6.04 .0005 7.04 .0009
- 8.05 .0014 10.06 .0006 11.07 .0003))
-
-(define fl-c5 '( 1.01 .0245 2.02 .1674 3.04 .0228 4.05 .0229 5.06 .0087 6.09 .0004 7.09 .0004
- 8.10 .0003 9.11 .0002 10.14 .0002 11.15 .0001))
-
-(define fl-cs5 '( 1.00 .0885 2.01 .0661 3.01 .0281 4.02 .0068 5.02 .0038 6.02 .0010 7.02 .0008
- 8.03 .0007 9.03 .0005 10.04 .0002 11.04 .0003))
-
-(define fl-d5 '( 1.01 .3830 2.01 .1043 3.01 .0372 4.02 .0175 5.03 .0035 6.03 .0011 7.04 .0010
- 8.04 .0004 9.04 .0002 10.05 .0001))
-
-(define fl-ds5 '( 1.00 .2294 2.01 .0606 3.01 .0238 4.01 .0050 5.01 .0041 6.02 .0007 7.02 .0007
- 8.02 .0006 10.03 .0002 12.03 .0001))
-
-(define fl-e5 '( 1.01 .3759 2.03 .0529 3.03 .0595 4.05 .0010 5.06 .0077 6.07 .0008 7.09 .0007
- 8.09 .0005 9.11 .0001 10.12 .0002 12.14 .0001))
-
-(define fl-f5 '( 1.01 .1982 2.02 .0204 3.02 .0554 4.03 .0064 5.04 .0040 6.05 .0016 7.06 .0007
- 8.07 .0006 9.07 .0001 10.08 .0001 12.10 .0001))
-
-(define fl-fs5 '( 1.01 .3241 2.02 .0548 3.03 .0082 4.04 .0022 5.05 .0038 6.06 .0004 7.07 .0009
- 8.09 .0001 9.09 .0003 10.10 .0001))
-
-(define fl-g5 '( 1.01 .4049 2.01 .0301 3.02 .0229 4.03 .0047 5.04 .0029 6.05 .0014 7.05 .0009
- 8.06 .0003 9.07 .0002 10.07 .0002 11.09 .0001 12.09 .0001))
-
-(define fl-gs5 '( 1.00 .5433 2.01 .0536 3.01 .0411 4.02 .0074 5.02 .0014 6.02 .0011 7.03 .0004
- 8.03 .0003 9.04 .0001))
-
-(define fl-a5 '( 1.01 .3063 2.01 .0346 3.02 .0102 4.03 .0031 5.03 .0007 6.04 .0010 7.03 .0003
- 8.06 .0001 9.05 .0002 11.06 .0002))
-
-(define fl-as5 '( 1.01 .1962 2.03 .0355 3.04 .0128 4.06 .0020 5.07 .0021 6.08 .0003 7.10 .0003
- 8.11 .0002))
-
-(define fl-b5 '( 1.01 .3829 2.02 .0120 3.03 .0037 4.04 .0030 5.05 .0016 6.06 .0006 7.07 .0002
- 8.08 .0004 9.09 .0001))
-
-(define fl-c6 '( 1.01 .3072 2.02 .0248 3.04 .0012 4.05 .0006 5.06 .0011 6.07 .0009 7.08 .0003
- 8.10 .0001 10.12 .0001))
-
-(define fl-cs6 '( 1.01 .1262 2.02 .0030 3.03 .0012 4.04 .0005 5.06 .0010 6.07 .0002 7.08 .0004
- 8.09 .0002))
-
-(define fl-d6 '( 1.01 .3050 2.03 .0071 3.04 .0107 4.06 .0005 5.07 .0015 6.08 .0002 7.10 .0003
- 8.11 .0002 9.13 .0001))
-
-(define fl-ds6 '( 1.02 .0954 2.05 .0025 3.06 .0047 4.09 .0007 5.11 .0017 6.13 .0001 7.15 .0002))
-
-(define fl-e6 '( 1.02 .2864 2.05 .0057 3.08 .0023 5.13 .0007 6.16 .0001 8.21 .0001))
-
-(define fl-f6 '( 1.03 .0675 2.05 .0049 3.08 .0024 5.13 .0008 6.16 .0002 7.18 .0002 8.21 .0001))
-
-(define fl-fs6 '( 1.02 .2553 2.05 .0044 3.07 .0032 5.12 .0007 6.14 .0002 8.19 .0001))
-
-(define fl-g6 '( 1.02 .1190 2.05 .0069 3.07 .0046 5.12 .0010 6.14 .0001 7.17 .0007 7.26 .0001))
-
-(define fl-gs6 '( 1.02 .3872 2.05 .0093 3.07 .0051 5.12 .0008 6.15 .0001 7.17 .0002 7.18 .0001))
-
-(define fl-a6 '( 1.02 .2920 2.04 .0122 3.06 .0052 4.08 .0007 5.10 .0003 6.31 .0002 7.15 .0003))
-
-(define fl-as6 '( 1.02 .5687 2.04 .0090 3.06 .0075 4.08 .0007 5.10 .0010 6.15 .0002 6.21 .0002
- 6.40 .0001 6.47 .0001))
-
-(define fl-b6 '( 1.03 .2752 2.06 .0061 3.09 .0039 5.14 .0002 5.86 .0002 6.18 .0001 6.24 .0001
- 6.45 .0001))
-
-(define fl-c7 '( 1.04 .2720 2.07 .0046 5.18 .0003 5.40 .0002 6.02 .0002))
-
-(define fl-cs7 '( 1.03 .3752 2.06 .0156 5.16 .0007 5.20 .0003 5.40 .0001 5.41 .0001 5.57 .0001))
-
-(define fl-d7 '( 1.04 .2861 2.07 .0147 5.18 .0012 5.27 .0002 5.30 .0001))
-
-;;;
-;;;
-;;;
-;;;
-;;; oboe?
-(define ob-as3 '( 1.00 .0504 2.00 .0724 2.99 .1036 3.99 .1215 4.99 .1360 5.99 .0852 6.98 .0593
- 7.97 .0230 8.98 .0077 9.97 .0063 10.97 .0016 11.96 .0008 12.97 .0017 13.97 .0017 14.96 .0020
- 15.96 .0007 16.96 .0006 17.96 .0002 21.95 .0001 22.95 .0001 23.94 .0002 24.94 .0002 25.94 .0001))
-
-(define ob-b3 '( .99 .0587 1.99 .0820 2.98 .0673 3.98 .1069 4.97 .1336 5.97 .0948 6.96 .0455
- 7.96 .0070 8.95 .0017 9.95 .0023 10.95 .0063 11.93 .0031 12.93 .0021 13.92 .0009 14.92 .0005
- 15.92 .0003 16.89 .0001 21.88 .0001 23.88 .0001))
-
-(define ob-c4 '( 1.00 .0784 2.00 .0494 2.99 .0668 3.99 .0785 4.99 .1406 5.99 .0747 6.99 .0460
- 7.98 .0147 8.98 .0115 9.97 .0083 10.98 .0058 11.98 .0059 12.97 .0027 13.98 .0010 14.96 .0006
- 15.97 .0002 16.96 .0001 17.96 .0002 19.95 .0001 20.96 .0002 21.95 .0001))
-
-(define ob-cs4 '( 1.00 .0801 2.00 .0526 2.99 .0568 3.99 .0713 4.99 .1811 5.99 .0721 6.99 .0491
- 7.98 .0201 8.98 .0128 9.98 .0132 10.98 .0104 11.98 .0081 12.97 .0055 13.97 .0026 14.97 .0010
- 15.97 .0003 16.97 .0004 17.96 .0003 18.97 .0004 19.95 .0006 20.96 .0003 21.96 .0002))
-
-(define ob-d4 '( 1.00 .0775 2.00 .0853 3.01 .0538 4.01 .0600 5.00 .1853 6.01 .0714 7.01 .0247
- 8.01 .0265 9.01 .0028 10.01 .0116 11.02 .0078 12.02 .0060 13.01 .0036 14.02 .0010 15.03 .0005
- 16.01 .0002 17.02 .0002 18.01 .0004 19.02 .0004 20.02 .0002 21.02 .0001))
-
-(define ob-ds4 '( 1.00 .0922 1.99 .0922 2.99 .0912 3.99 .0337 4.98 .1696 5.97 .0481 6.98 .0184
- 7.97 .0104 8.96 .0185 9.96 .0147 10.96 .0057 11.95 .0039 12.95 .0012 13.94 .0006 14.94 .0009
- 15.94 .0005 16.93 .0005 17.93 .0003 18.93 .0001 19.92 .0001))
-
-(define ob-e4 '( 1.00 .0970 2.01 .0554 3.01 .0624 4.02 .1806 5.02 .1392 6.02 .0367 7.03 .0165
- 8.04 .0102 9.04 .0159 10.04 .0077 11.04 .0092 12.05 .0027 13.06 .0004 14.06 .0007 15.06 .0003
- 16.07 .0006 17.07 .0003 18.08 .0003 19.08 .0001 20.09 .0002))
-
-(define ob-f4 '( 1.00 .0988 2.01 .0364 3.00 .0573 4.01 .2291 5.01 .0802 6.02 .0188 7.02 .0160
- 8.02 .0143 9.02 .0152 10.02 .0140 11.03 .0054 12.01 .0003 13.03 .0012 14.03 .0008 15.04 .0008
- 16.04 .0006 17.04 .0006 18.04 .0003 19.05 .0001))
-
-(define ob-fs4 '( 1.01 .0340 2.01 .0618 3.02 .0923 4.03 .1479 5.03 .1058 6.04 .0281 7.05 .0071
- 8.05 .0157 9.06 .0018 10.07 .0014 11.07 .0005 12.08 .0013 13.09 .0012 14.10 .0005 15.10 .0003
- 16.11 .0005 17.12 .0002))
-
-(define ob-g4 '( 1.01 .0606 2.01 .0774 3.02 .0552 4.03 .0700 5.04 .0194 6.04 .0066 7.05 .0147
- 8.06 .0134 9.07 .0055 10.08 .0035 11.08 .0004 12.10 .0004 13.10 .0008 14.11 .0011 15.10 .0004))
-
-(define ob-gs4 '( 1.01 .0573 2.01 .0346 3.03 .0608 4.03 .0675 5.04 .0643 6.05 .0193 7.06 .0125
- 8.07 .0109 9.07 .0010 10.09 .0003 11.09 .0016 12.10 .0015 13.11 .0006 14.11 .0003 15.13 .0002
- 16.13 .0002))
-
-(define ob-a4 '( 1.00 .0923 2.00 .0358 3.00 .0726 4.00 .2111 5.00 .0316 5.99 .0016 7.00 .0080
- 8.00 .0075 9.00 .0031 10.01 .0007 11.01 .0008 12.00 .0005 13.00 .0003 14.01 .0005 15.01 .0001))
-
-(define ob-as4 '( 1.00 .0753 2.00 .0693 3.00 .3731 4.01 .0810 5.01 .0245 6.00 .0142 7.00 .0061
- 8.01 .0025 9.01 .0004 10.01 .0005 11.01 .0005 12.02 .0005 13.02 .0003))
-
-(define ob-b4 '( 1.00 .0618 2.01 .0377 3.02 .0642 4.02 .0401 5.02 .0165 6.03 .0176 7.03 .0079
- 8.04 .0016 9.04 .0003 10.06 .0003 11.05 .0006 12.06 .0003 13.06 .0001))
-
-(define ob-c5 '( 1.01 .0484 2.02 .0490 3.02 .0364 4.03 .0166 5.03 .0172 6.04 .0261 7.05 .0120
- 8.06 .0021 9.06 .0035 10.07 .0021 11.08 .0008 12.08 .0003))
-
-(define ob-cs5 '( 1.01 .1071 2.02 .0487 3.03 .1175 4.04 .0329 5.05 .0231 6.06 .0136 7.07 .0047
- 8.07 .0009 9.09 .0011 10.10 .0016 11.10 .0010 12.12 .0002))
-
-(define ob-d5 '( 1.01 .1893 2.01 .0986 3.02 .1665 4.02 .0326 5.03 .0275 6.04 .0155 7.04 .0029
- 8.05 .0013 9.06 .0016 10.07 .0010 11.07 .0004 12.08 .0001))
-
-(define ob-ds5 '( 1.00 .2003 2.00 .0265 3.00 .1047 4.00 .0138 5.00 .0391 6.00 .0094 6.99 .0023
- 8.00 .0018 8.99 .0011 9.99 .0006 10.99 .0002 11.99 .0001))
-
-(define ob-e5 '( 1.00 .0906 2.00 .4215 3.00 .1046 3.99 .0081 4.99 .0118 5.99 .0054 6.99 .0005
- 7.99 .0014 8.99 .0005 9.99 .0002))
-
-(define ob-f5 '( 1.00 .0657 2.00 .4134 2.99 .0463 3.99 .0144 4.99 .0277 5.99 .0047 6.98 .0005
- 7.98 .0004 8.98 .0003))
-
-(define ob-fs5 '( 1.01 .0957 2.03 .2943 3.04 .0855 4.06 .0568 5.07 .0247 6.08 .0013 7.10 .0024
- 8.12 .0011 9.13 .0006 10.15 .0002 11.16 .0001 12.17 .0001))
-
-(define ob-g5 '( 1.01 .0975 2.02 .1012 3.04 .0543 4.05 .0298 5.06 .0083 6.07 .0026 7.08 .0017
- 8.09 .0003 9.11 .0001))
-
-(define ob-gs5 '( 1.01 .0400 2.01 .0481 3.02 .0403 4.02 .0169 5.03 .0002 6.04 .0030 7.04 .0008))
-
-(define ob-a5 '( 1.01 .0725 2.02 .1474 3.03 .0327 4.04 .0281 5.05 .0013 6.06 .0028 7.07 .0004))
-
-(define ob-as5 '( 1.00 .0837 2.00 .1039 3.00 .0366 4.01 .0118 5.01 .0021 6.01 .0012))
-
-(define ob-b5 '( 1.02 .0812 2.04 .0709 3.06 .0658 4.08 .0099 5.10 .0069 6.12 .0007 7.14 .0001
- 8.16 .0001))
-
-(define ob-c6 '( 1.01 .0799 2.02 .0161 3.02 .0476 4.03 .0084 5.04 .0029 6.05 .0002))
-
-(define ob-cs6 '( 1.01 .2331 2.02 .1151 3.03 .0163 4.04 .0013 5.05 .0004 6.07 .0003))
-
-(define ob-d6 '( 1.02 .2469 2.03 .0288 3.05 .0144 4.06 .0012 5.08 .0008))
-
-(define ob-ds6 '( 1.00 .2770 2.00 .0028 3.00 .0095 4.00 .0042 5.00 .0006 5.99 .0002))
-
-(define ob-e6 '( 1.00 .3019 2.01 .0125 3.01 .0049 4.02 .0008 5.02 .0001 6.02 .0001))
-
-(define ob-f6 '( 1.01 .0898 2.01 .0089 3.02 .0067 4.02 .0010 5.03 .0002 6.03 .0001))
-
-(define ob-fs6 '( 1.01 .1330 2.03 .0090 3.05 .0031 4.06 .0001))
-
-(define ob-g6 '( 1.00 .1046 1.99 .0228 2.99 .0004 3.98 .0001))
-
-;;;
-;;;
-;;;
-;;;
-;;; piano
-(define p-c1 '( 1.97 .0326 2.99 .0086 3.95 .0163 4.97 .0178 5.98 .0177 6.95 .0315 8.02 .0001
- 8.94 .0076 9.96 .0134 10.99 .0284 11.98 .0229 13.02 .0229 13.89 .0010 15.06 .0090 16.00 .0003
- 17.08 .0078 18.16 .0064 19.18 .0129 20.21 .0085 21.27 .0225 22.32 .0061 23.41 .0102 24.48 .0005
- 25.56 .0016 26.64 .0018 27.70 .0113 28.80 .0111 29.91 .0158 31.06 .0093 32.17 .0017 33.32 .0002
- 34.42 .0018 35.59 .0027 36.74 .0055 37.90 .0037 39.06 .0064 40.25 .0033 41.47 .0014 42.53 .0004
- 43.89 .0010 45.12 .0039 46.33 .0039 47.64 .0009 48.88 .0016 50.13 .0006 51.37 .0010 52.70 .0002
- 54.00 .0004 55.30 .0008 56.60 .0025 57.96 .0010 59.30 .0012 60.67 .0011 61.99 .0003 62.86 .0001
- 64.36 .0005 64.86 .0001 66.26 .0004 67.70 .0006 68.94 .0002 70.10 .0001 70.58 .0002 72.01 .0007
- 73.53 .0006 75.00 .0002 77.03 .0005 78.00 .0002 79.57 .0006 81.16 .0005 82.70 .0005 84.22 .0003
- 85.41 .0002 87.46 .0001 90.30 .0001 94.02 .0001 95.26 .0002 109.39 .0003))
-
-(define p-cs1 '( 1.98 .0194 2.99 .0210 3.97 .0276 4.96 .0297 5.96 .0158 6.99 .0207 8.01 .0009
- 9.00 .0101 10.00 .0297 11.01 .0289 12.02 .0211 13.04 .0127 14.07 .0061 15.08 .0174 16.13 .0009
- 17.12 .0093 18.16 .0117 19.21 .0122 20.29 .0108 21.30 .0077 22.38 .0132 23.46 .0073 24.14 .0002
- 25.58 .0026 26.69 .0035 27.77 .0053 28.88 .0024 30.08 .0027 31.13 .0075 32.24 .0027 33.36 .0004
- 34.42 .0004 35.64 .0019 36.78 .0037 38.10 .0009 39.11 .0027 40.32 .0010 41.51 .0013 42.66 .0019
- 43.87 .0007 45.13 .0017 46.35 .0019 47.65 .0021 48.89 .0014 50.18 .0023 51.42 .0015 52.73 .0002
- 54.00 .0005 55.34 .0006 56.60 .0010 57.96 .0016 58.86 .0005 59.30 .0004 60.75 .0005 62.22 .0003
- 63.55 .0005 64.82 .0003 66.24 .0003 67.63 .0011 69.09 .0007 70.52 .0004 72.00 .0005 73.50 .0008
- 74.95 .0003 77.13 .0013 78.02 .0002 79.48 .0004 82.59 .0004 84.10 .0003))
-
-(define p-d1 '( 2.00 .0313 2.99 .0109 4.00 .0215 5.00 .0242 5.98 .0355 7.01 .0132 8.01 .0009
- 9.01 .0071 10.00 .0258 11.03 .0221 12.02 .0056 13.06 .0196 14.05 .0160 15.11 .0107 16.11 .0003
- 17.14 .0111 18.21 .0085 19.23 .0010 20.28 .0048 21.31 .0128 22.36 .0051 23.41 .0041 24.05 .0006
- 25.54 .0019 26.62 .0028 27.72 .0034 28.82 .0062 29.89 .0039 30.98 .0058 32.08 .0011 33.21 .0002
- 34.37 .0008 35.46 .0018 36.62 .0036 37.77 .0018 38.92 .0042 40.07 .0037 41.23 .0011 42.67 .0003
- 43.65 .0018 44.68 .0025 45.99 .0044 47.21 .0051 48.40 .0044 49.67 .0005 50.88 .0019 52.15 .0003
- 53.42 .0008 54.69 .0010 55.98 .0005 57.26 .0013 58.53 .0027 59.83 .0011 61.21 .0027 62.54 .0003
- 63.78 .0003 65.20 .0001 66.60 .0006 67.98 .0008 69.37 .0019 70.73 .0007 72.14 .0004 73.62 .0002
- 74.40 .0003 76.52 .0006 77.97 .0002 79.49 .0004 80.77 .0003 81.00 .0001 82.47 .0005 83.97 .0001
- 87.27 .0002))
-
-(define p-ds1 '( 2.00 .0257 2.99 .0142 3.97 .0202 4.95 .0148 5.95 .0420 6.95 .0037 7.94 .0004
- 8.94 .0172 9.95 .0191 10.96 .0115 11.97 .0059 12.98 .0140 14.00 .0178 15.03 .0121 16.09 .0002
- 17.07 .0066 18.08 .0033 19.15 .0022 20.18 .0057 21.22 .0077 22.29 .0037 23.33 .0066 24.97 .0002
- 25.49 .0019 26.55 .0042 27.61 .0043 28.73 .0038 29.81 .0084 30.91 .0040 32.03 .0025 33.14 .0005
- 34.26 .0003 35.38 .0019 36.56 .0037 37.68 .0049 38.86 .0036 40.11 .0011 41.28 .0008 42.50 .0004
- 43.60 .0002 44.74 .0022 45.99 .0050 47.20 .0009 48.40 .0036 49.68 .0004 50.92 .0009 52.17 .0005
- 53.46 .0007 54.76 .0006 56.06 .0005 57.34 .0011 58.67 .0005 59.95 .0015 61.37 .0008 62.72 .0004
- 65.42 .0009 66.96 .0003 68.18 .0003 69.78 .0003 71.21 .0004 72.45 .0002 74.22 .0003 75.44 .0001
- 76.53 .0003 78.31 .0004 79.83 .0003 80.16 .0001 81.33 .0003 82.44 .0001 83.17 .0002 84.81 .0003
- 85.97 .0003 89.08 .0001 90.70 .0002 92.30 .0002 95.59 .0002 97.22 .0003 98.86 .0001 108.37 .0001
- 125.54 .0001))
-
-(define p-e1 '( 1.99 .0650 3.03 .0040 4.03 .0059 5.02 .0090 5.97 .0227 6.98 .0050 8.04 .0020
- 9.00 .0082 9.96 .0078 11.01 .0056 12.01 .0095 13.02 .0050 14.04 .0093 15.08 .0064 16.14 .0017
- 17.06 .0020 18.10 .0025 19.14 .0023 20.18 .0015 21.24 .0032 22.29 .0029 23.32 .0014 24.37 .0005
- 25.43 .0030 26.50 .0022 27.60 .0027 28.64 .0024 29.76 .0035 30.81 .0136 31.96 .0025 33.02 .0003
- 34.13 .0005 35.25 .0007 36.40 .0014 37.51 .0020 38.64 .0012 39.80 .0019 40.97 .0004 42.09 .0003
- 43.24 .0003 44.48 .0002 45.65 .0024 46.86 .0005 48.07 .0013 49.27 .0008 50.49 .0006 52.95 .0001
- 54.23 .0005 55.45 .0004 56.73 .0001 58.03 .0003 59.29 .0002 60.59 .0003 62.04 .0002 65.89 .0002
- 67.23 .0002 68.61 .0002 69.97 .0004 71.36 .0005 85.42 .0001))
-
-(define p-f1 '( 1.98 .0256 2.96 .0158 3.95 .0310 4.94 .0411 5.95 .0238 6.94 .0152 7.93 .0011
- 8.95 .0185 9.92 .0166 10.93 .0306 11.94 .0258 12.96 .0202 13.97 .0403 14.95 .0228 15.93 .0005
- 17.01 .0072 18.02 .0034 19.06 .0028 20.08 .0124 21.13 .0137 22.16 .0102 23.19 .0058 23.90 .0013
- 25.30 .0039 26.36 .0039 27.41 .0025 28.47 .0071 29.64 .0031 30.60 .0027 31.71 .0021 32.84 .0003
- 33.82 .0002 35.07 .0019 36.09 .0054 37.20 .0038 38.33 .0024 39.47 .0055 40.55 .0016 41.77 .0006
- 42.95 .0002 43.27 .0018 44.03 .0006 45.25 .0019 46.36 .0033 47.50 .0024 48.87 .0012 50.03 .0016
- 51.09 .0004 53.52 .0017 54.74 .0012 56.17 .0003 57.40 .0011 58.42 .0020 59.70 .0007 61.29 .0008
- 62.56 .0003 63.48 .0002 64.83 .0002 66.12 .0012 67.46 .0017 68.81 .0003 69.13 .0003 70.53 .0002
- 71.84 .0001 73.28 .0002 75.52 .0010 76.96 .0005 77.93 .0003 78.32 .0003 79.73 .0003 81.69 .0002
- 82.52 .0001 84.01 .0001 84.61 .0002 86.88 .0001 88.36 .0002 89.85 .0002 91.35 .0003 92.86 .0002
- 93.40 .0001 105.28 .0002 106.22 .0002 107.45 .0001 108.70 .0003 122.08 .0002))
-
-(define p-fs1 '( 1.97 .0264 2.97 .0211 3.98 .0234 4.98 .0307 5.96 .0085 6.94 .0140 7.93 .0005
- 8.96 .0112 9.96 .0209 10.98 .0194 11.98 .0154 12.99 .0274 13.99 .0127 15.01 .0101 15.99 .0002
- 17.04 .0011 18.08 .0032 19.14 .0028 20.12 .0054 21.20 .0053 22.13 .0028 23.22 .0030 24.32 .0006
- 25.24 .0004 26.43 .0028 27.53 .0048 28.52 .0039 29.54 .0047 30.73 .0044 31.82 .0007 32.94 .0008
- 34.04 .0012 35.13 .0018 36.29 .0007 37.35 .0075 38.51 .0045 39.66 .0014 40.90 .0004 41.90 .0002
- 43.08 .0002 44.24 .0017 45.36 .0013 46.68 .0020 47.79 .0015 48.98 .0010 50.21 .0012 51.34 .0001
- 53.82 .0003 55.09 .0004 56.23 .0005 57.53 .0004 58.79 .0005 59.30 .0002 60.03 .0002 61.40 .0003
- 62.84 .0001 66.64 .0001 67.97 .0001 69.33 .0001 70.68 .0001 73.57 .0002 75.76 .0002 76.45 .0001
- 79.27 .0001 80.44 .0002 81.87 .0002))
-
-(define p-g1 '( 2.00 .0311 2.99 .0086 3.99 .0266 4.97 .0123 5.98 .0235 6.97 .0161 7.97 .0008
- 8.96 .0088 9.96 .0621 10.99 .0080 11.99 .0034 12.99 .0300 14.03 .0228 15.04 .0105 16.03 .0004
- 17.06 .0036 18.09 .0094 18.95 .0009 20.17 .0071 21.21 .0161 22.25 .0106 23.28 .0104 24.33 .0008
- 25.38 .0030 26.46 .0035 27.50 .0026 28.59 .0028 29.66 .0128 30.75 .0139 31.81 .0038 32.93 .0006
- 34.04 .0004 35.16 .0005 36.25 .0023 37.35 .0012 38.46 .0021 39.59 .0035 40.71 .0006 41.86 .0007
- 42.42 .0001 43.46 .0003 44.17 .0032 45.29 .0013 46.57 .0004 47.72 .0011 48.79 .0005 50.11 .0005
- 51.29 .0003 52.47 .0002 53.68 .0004 55.02 .0005 56.18 .0003 57.41 .0003 58.75 .0007 59.33 .0009
- 60.00 .0004 61.34 .0001 64.97 .0003 65.20 .0002 66.48 .0002 67.83 .0002 68.90 .0003 70.25 .0003
- 71.59 .0002 73.68 .0001 75.92 .0001 77.08 .0002 78.45 .0002 81.56 .0002 82.99 .0001 88.39 .0001))
-
-(define p-gs1 '( .97 .0059 1.98 .0212 2.99 .0153 3.99 .0227 4.96 .0215 5.97 .0153 6.98 .0085
- 7.98 .0007 8.97 .0179 9.98 .0512 10.98 .0322 12.00 .0098 13.02 .0186 14.00 .0099 15.05 .0109
- 15.88 .0011 17.07 .0076 18.11 .0071 19.12 .0045 20.16 .0038 21.23 .0213 22.27 .0332 23.34 .0082
- 24.34 .0014 25.42 .0024 26.47 .0012 27.54 .0014 28.60 .0024 29.72 .0026 30.10 .0008 31.91 .0021
- 32.13 .0011 33.02 .0007 34.09 .0014 35.17 .0007 36.27 .0024 37.39 .0029 38.58 .0014 39.65 .0017
- 40.95 .0012 41.97 .0004 42.43 .0002 43.49 .0001 44.31 .0012 45.42 .0031 46.62 .0017 47.82 .0013
- 49.14 .0013 50.18 .0010 51.54 .0003 53.90 .0006 55.06 .0010 56.31 .0003 57.63 .0001 59.02 .0003
- 60.09 .0004 60.35 .0004 61.62 .0009 63.97 .0001 65.19 .0001 65.54 .0002 66.92 .0002 67.94 .0002
- 69.17 .0003 69.60 .0004 70.88 .0002 72.24 .0002 76.12 .0001 78.94 .0001 81.75 .0001 82.06 .0001
- 83.53 .0001 90.29 .0002 91.75 .0001 92.09 .0002 93.28 .0001 97.07 .0001))
-
-(define p-a1 '( 1.98 .0159 2.98 .1008 3.98 .0365 4.98 .0133 5.97 .0101 6.97 .0115 7.97 .0007
- 8.99 .0349 10.01 .0342 11.01 .0236 12.00 .0041 13.02 .0114 14.05 .0137 15.06 .0100 16.05 .0007
- 17.04 .0009 18.12 .0077 19.15 .0023 20.12 .0017 21.24 .0113 22.26 .0126 23.30 .0093 24.36 .0007
- 25.43 .0007 26.47 .0009 27.55 .0013 28.59 .0025 29.61 .0010 30.77 .0021 31.86 .0023 32.96 .0003
- 34.03 .0007 35.06 .0005 36.20 .0006 37.34 .0006 38.36 .0009 39.60 .0016 40.69 .0005 41.77 .0002
- 42.92 .0002 44.02 .0003 45.24 .0006 46.33 .0004 47.50 .0007 48.71 .0007 49.87 .0002 51.27 .0002
- 53.42 .0003 55.88 .0003 57.10 .0004 58.34 .0002 59.86 .0003 61.13 .0003 67.18 .0001 68.50 .0001
- 71.17 .0001 83.91 .0001 90.55 .0001))
-
-(define p-as1 '( .98 .0099 2.00 .0181 2.99 .0353 3.98 .0285 4.97 .0514 5.96 .0402 6.96 .0015
- 7.98 .0012 8.98 .0175 9.98 .0264 10.98 .0392 11.98 .0236 13.00 .0153 14.04 .0049 15.00 .0089
- 16.01 .0001 17.03 .0106 18.03 .0028 19.05 .0024 20.08 .0040 21.11 .0103 22.12 .0104 23.20 .0017
- 24.19 .0008 25.20 .0007 26.24 .0011 27.36 .0009 27.97 .0030 29.40 .0044 30.37 .0019 31.59 .0017
- 32.65 .0008 33.59 .0005 34.79 .0009 35.75 .0027 36.88 .0035 37.93 .0039 39.00 .0031 40.08 .0025
- 41.16 .0010 43.25 .0004 44.52 .0012 45.62 .0023 45.85 .0012 47.00 .0006 47.87 .0008 48.99 .0003
- 50.48 .0003 51.62 .0001 52.43 .0001 53.56 .0002 54.76 .0002 56.04 .0002 56.68 .0006 57.10 .0003
- 58.28 .0005 59.47 .0003 59.96 .0002 60.67 .0001 63.08 .0002 64.29 .0002 66.72 .0001 67.97 .0001
- 68.65 .0001 70.43 .0001 79.38 .0001 80.39 .0001 82.39 .0001))
-
-(define p-b1 '( 1.00 .0765 1.99 .0151 2.99 .0500 3.99 .0197 5.00 .0260 6.00 .0145 6.98 .0128
- 7.97 .0004 8.98 .0158 9.99 .0265 11.02 .0290 12.02 .0053 13.03 .0242 14.03 .0103 15.06 .0054
- 16.04 .0006 17.08 .0008 18.10 .0058 19.16 .0011 20.16 .0055 21.18 .0040 22.20 .0019 23.22 .0014
- 24.05 .0005 25.31 .0019 26.38 .0018 27.44 .0022 28.45 .0024 29.57 .0073 30.58 .0032 31.66 .0071
- 32.73 .0015 33.85 .0005 34.96 .0003 36.00 .0020 37.11 .0018 38.18 .0055 39.23 .0006 40.33 .0004
- 41.52 .0003 43.41 .0028 45.05 .0003 45.99 .0002 47.07 .0003 48.52 .0002 49.48 .0003 50.63 .0003
- 51.81 .0002 54.05 .0002 55.24 .0001 56.62 .0001 57.81 .0004 59.16 .0013 60.23 .0003 66.44 .0001
- 68.99 .0004 75.49 .0001 87.56 .0004))
-
-(define p-c2 '( .98 .0629 1.99 .0232 2.98 .0217 4.00 .0396 4.98 .0171 5.97 .0098 6.99 .0167
- 7.99 .0003 8.98 .0192 9.98 .0266 10.99 .0256 12.01 .0061 13.02 .0135 14.02 .0062 15.05 .0158
- 16.06 .0018 17.08 .0101 18.09 .0053 19.11 .0074 20.13 .0020 21.17 .0052 22.22 .0077 23.24 .0035
- 24.00 .0009 25.32 .0016 26.40 .0022 27.43 .0005 28.55 .0026 29.60 .0026 30.65 .0010 31.67 .0019
- 32.77 .0008 33.81 .0003 34.91 .0003 36.01 .0005 37.11 .0010 38.20 .0014 39.29 .0039 40.43 .0012
- 41.50 .0006 43.38 .0017 43.75 .0002 44.94 .0005 46.13 .0002 47.11 .0003 48.28 .0005 48.42 .0005
- 49.44 .0003 50.76 .0004 51.93 .0002 54.15 .0003 55.31 .0005 55.50 .0003 56.98 .0003 57.90 .0004
- 60.33 .0002 61.39 .0001 61.59 .0001 65.09 .0002 66.34 .0001 68.85 .0001 70.42 .0002 71.72 .0001
- 73.05 .0003 79.65 .0001 85.28 .0002 93.52 .0001))
-
-(define p-cs2 '( 1.02 .0185 1.99 .0525 2.98 .0613 3.99 .0415 4.98 .0109 5.97 .0248 6.99 .0102
- 7.98 .0005 8.98 .0124 9.99 .0103 10.99 .0124 12.00 .0016 13.01 .0029 14.03 .0211 15.04 .0128
- 16.07 .0021 17.09 .0009 18.09 .0043 19.14 .0022 20.13 .0016 21.20 .0045 22.21 .0088 23.26 .0046
- 24.29 .0013 25.35 .0009 26.39 .0028 27.49 .0009 28.51 .0006 29.58 .0012 30.70 .0010 31.74 .0019
- 32.75 .0002 33.85 .0001 34.95 .0005 36.02 .0003 37.16 .0009 38.25 .0018 39.35 .0008 40.54 .0004
- 41.61 .0002 43.40 .0004 43.74 .0003 45.05 .0001 46.11 .0003 47.40 .0002 48.36 .0004 49.55 .0004
- 50.72 .0002 52.00 .0001 55.58 .0002 57.02 .0001 57.98 .0002 59.13 .0003 61.56 .0001 66.56 .0001
- 87.65 .0002))
-
-(define p-d2 '( 1.00 .0473 1.99 .0506 2.99 .0982 3.99 .0654 5.00 .0196 5.99 .0094 6.99 .0118
- 7.93 .0001 8.99 .0057 10.01 .0285 11.01 .0142 12.03 .0032 13.03 .0056 14.06 .0064 15.06 .0059
- 16.11 .0005 17.09 .0033 18.14 .0027 19.15 .0014 20.17 .0010 21.21 .0059 22.26 .0043 23.31 .0031
- 24.31 .0018 25.33 .0009 26.41 .0005 27.47 .0015 28.53 .0015 29.58 .0041 30.65 .0025 31.73 .0011
- 32.83 .0010 34.98 .0003 36.07 .0009 37.23 .0001 38.26 .0020 39.41 .0014 40.53 .0005 41.40 .0003
- 42.80 .0002 43.48 .0028 43.93 .0001 45.03 .0003 46.18 .0007 47.41 .0001 48.57 .0002 49.67 .0001
- 50.83 .0002 54.39 .0001 55.58 .0002 57.97 .0005 58.11 .0002 59.21 .0001 60.42 .0002 61.66 .0001))
-
-(define p-ds2 '( 1.00 .0503 2.00 .0963 2.99 .1304 3.99 .0218 4.98 .0041 5.98 .0292 6.98 .0482
- 7.99 .0005 8.99 .0280 10.00 .0237 11.00 .0152 12.02 .0036 12.95 .0022 14.06 .0111 15.07 .0196
- 16.08 .0016 17.11 .0044 18.13 .0073 19.17 .0055 20.19 .0028 21.20 .0012 22.27 .0068 23.30 .0036
- 24.35 .0012 25.35 .0002 26.46 .0005 27.47 .0005 28.59 .0009 29.65 .0021 30.70 .0020 31.78 .0012
- 32.89 .0010 35.06 .0005 36.16 .0008 37.27 .0010 38.36 .0010 39.47 .0014 40.58 .0004 41.43 .0007
- 41.82 .0003 43.48 .0008 44.53 .0001 45.25 .0003 46.43 .0002 47.46 .0002 48.76 .0005 49.95 .0004
- 50.96 .0002 51.12 .0002 52.33 .0001 54.75 .0001 55.75 .0002 56.90 .0002 58.17 .0002 59.40 .0004
- 60.62 .0002 65.65 .0001 66.91 .0002 69.91 .0001 71.25 .0002))
-
-(define p-e2 '( 1.00 .1243 1.98 .1611 3.00 .0698 3.98 .0390 5.00 .0138 5.99 .0154 7.01 .0287
- 8.01 .0014 9.01 .0049 10.00 .0144 11.01 .0055 12.05 .0052 13.01 .0011 14.05 .0118 15.07 .0154
- 16.12 .0028 17.14 .0061 18.25 .0007 19.22 .0020 20.24 .0011 21.27 .0029 22.30 .0046 23.34 .0049
- 24.35 .0004 25.45 .0003 26.47 .0007 27.59 .0008 28.16 .0009 29.12 .0002 29.81 .0006 30.81 .0009
- 31.95 .0004 33.00 .0011 34.12 .0005 35.18 .0003 36.30 .0008 37.38 .0003 38.55 .0003 39.64 .0006
- 40.77 .0007 41.52 .0006 41.89 .0006 43.04 .0011 43.60 .0009 44.31 .0002 45.68 .0002 46.56 .0003
- 47.60 .0001 48.83 .0006 50.01 .0003 51.27 .0003 56.04 .0005 57.21 .0003 58.56 .0004 59.83 .0003
- 61.05 .0001 62.20 .0001 67.37 .0002 76.53 .0001))
-
-(define p-f2 '( .99 .0222 1.99 .0678 2.99 .0683 4.00 .0191 5.00 .0119 6.01 .0232 6.98 .0336
- 7.99 .0082 9.01 .0201 10.01 .0189 11.01 .0041 12.01 .0053 13.05 .0154 14.04 .0159 15.06 .0092
- 16.11 .0038 17.12 .0014 18.15 .0091 19.16 .0006 20.30 .0012 21.25 .0061 22.28 .0099 23.34 .0028
- 24.38 .0012 25.43 .0016 26.49 .0048 27.55 .0025 28.62 .0015 29.71 .0032 30.78 .0077 31.88 .0011
- 32.97 .0007 34.08 .0006 35.16 .0008 36.28 .0004 37.41 .0006 38.54 .0005 39.62 .0002 40.80 .0003
- 41.93 .0001 43.06 .0002 44.21 .0003 45.38 .0002 46.54 .0007 47.78 .0003 48.95 .0004 50.10 .0003
- 51.37 .0002 53.79 .0003 56.20 .0001 58.71 .0002 66.47 .0003))
-
-(define p-fs2 '( 1.01 .0241 1.99 .1011 2.98 .0938 3.98 .0081 4.99 .0062 5.99 .0291 6.99 .0676
- 7.59 .0004 8.98 .0127 9.99 .0112 10.99 .0142 12.00 .0029 13.02 .0071 14.02 .0184 15.03 .0064
- 16.07 .0010 17.09 .0011 18.11 .0010 19.15 .0060 20.19 .0019 21.24 .0025 22.29 .0013 23.31 .0050
- 25.41 .0030 26.50 .0018 27.53 .0006 28.63 .0012 29.66 .0013 30.77 .0020 31.84 .0006 34.04 .0001
- 35.14 .0001 36.32 .0004 37.41 .0007 38.53 .0007 39.67 .0009 40.85 .0003 45.49 .0002 46.65 .0001
- 47.81 .0004 49.01 .0002 53.91 .0002 55.14 .0002 57.69 .0002))
-
-(define p-g2 '( 1.00 .0326 2.00 .1066 2.99 .1015 4.00 .0210 4.97 .0170 5.99 .0813 6.98 .0820
- 7.96 .0011 8.99 .0248 10.03 .0107 11.01 .0126 12.01 .0027 13.01 .0233 14.04 .0151 15.05 .0071
- 16.04 .0002 17.10 .0061 18.12 .0059 19.15 .0087 20.23 .0005 21.25 .0040 22.30 .0032 23.35 .0004
- 24.40 .0001 25.45 .0030 26.54 .0022 27.60 .0003 28.70 .0009 29.80 .0029 30.85 .0006 31.97 .0006
- 34.19 .0004 35.30 .0003 36.43 .0007 37.56 .0005 38.68 .0019 39.88 .0013 41.00 .0003 43.35 .0003
- 44.51 .0002 45.68 .0006 46.93 .0010 48.11 .0006 49.29 .0003 55.58 .0002))
-
-(define p-gs2 '( .98 .0113 1.99 .0967 3.00 .0719 3.98 .0345 4.98 .0121 6.00 .0621 7.00 .0137
- 7.98 .0006 9.01 .0314 10.01 .0171 11.02 .0060 12.03 .0024 13.05 .0077 14.07 .0040 15.12 .0032
- 16.13 .0004 17.15 .0011 18.20 .0028 19.18 .0003 20.26 .0003 21.31 .0025 22.35 .0021 23.39 .0005
- 25.55 .0002 26.62 .0014 27.70 .0003 28.78 .0005 29.90 .0030 31.01 .0011 32.12 .0005 34.31 .0001
- 35.50 .0002 36.62 .0002 37.76 .0005 38.85 .0002 40.09 .0004 43.60 .0001 44.73 .0002 46.02 .0002
- 47.25 .0004 48.44 .0004))
-
-(define p-a2 '( .99 .0156 1.98 .0846 2.98 .0178 3.98 .0367 4.98 .0448 5.98 .0113 6.99 .0189
- 8.00 .0011 9.01 .0247 10.02 .0089 11.01 .0184 12.03 .0105 13.00 .0039 14.07 .0116 15.09 .0078
- 16.13 .0008 17.14 .0064 18.19 .0029 19.22 .0028 20.25 .0017 21.32 .0043 22.37 .0055 23.42 .0034
- 24.48 .0004 25.54 .0002 26.61 .0017 27.70 .0011 28.80 .0002 29.89 .0019 30.97 .0028 32.09 .0007
- 34.30 .0002 35.44 .0003 36.55 .0001 37.69 .0004 38.93 .0002 40.05 .0005 41.20 .0005 42.37 .0002
- 43.54 .0003 44.73 .0001 45.95 .0002 47.16 .0001 48.43 .0005 49.65 .0004 55.90 .0002 59.81 .0004))
-
-(define p-as2 '( 1.01 .0280 2.00 .0708 2.99 .0182 3.99 .0248 4.98 .0245 5.98 .0279 6.98 .0437
- 7.99 .0065 8.99 .0299 10.00 .0073 10.99 .0011 12.03 .0122 13.03 .0028 14.08 .0044 15.11 .0097
- 16.15 .0010 17.17 .0025 18.19 .0017 19.24 .0008 20.28 .0040 21.32 .0024 22.38 .0008 23.46 .0032
- 24.52 .0010 25.59 .0008 26.68 .0009 27.76 .0012 28.88 .0003 29.95 .0005 31.05 .0017 32.14 .0002
- 33.29 .0003 37.88 .0002 39.03 .0002 40.19 .0004 41.37 .0003 43.74 .0002 46.20 .0001 48.68 .0001
- 49.93 .0001 51.19 .0002))
-
-(define p-b2 '( 1.00 .0225 1.99 .0921 2.98 .0933 3.99 .0365 4.99 .0100 5.98 .0213 6.98 .0049
- 7.98 .0041 8.98 .0090 9.99 .0068 11.01 .0040 12.03 .0086 13.02 .0015 14.04 .0071 15.09 .0082
- 16.14 .0011 17.15 .0014 18.18 .0010 19.26 .0013 20.26 .0005 21.33 .0006 22.36 .0011 23.46 .0016
- 24.52 .0004 25.59 .0002 26.70 .0006 27.78 .0007 28.87 .0002 30.03 .0008 31.14 .0010 32.24 .0006
- 33.37 .0002 35.67 .0003 37.99 .0004 39.17 .0004 40.35 .0005 41.53 .0001 46.42 .0001))
-
-(define p-c3 '( 1.00 .0465 1.99 .0976 2.98 .0678 4.00 .0727 4.99 .0305 5.98 .0210 6.98 .0227
- 8.00 .0085 9.01 .0183 10.02 .0258 11.05 .0003 12.06 .0061 13.05 .0021 14.10 .0089 15.12 .0077
- 16.16 .0016 17.21 .0061 18.23 .0011 19.29 .0031 20.36 .0031 21.41 .0007 22.48 .0013 23.55 .0020
- 24.64 .0004 25.74 .0005 26.81 .0006 27.95 .0006 29.03 .0001 30.22 .0010 31.30 .0004 32.48 .0001
- 33.60 .0002 38.30 .0003))
-
-(define p-cs3 '( 1.00 .0674 1.99 .0841 2.98 .0920 3.99 .0328 4.99 .0368 5.98 .0206 6.99 .0246
- 8.01 .0048 9.01 .0218 10.03 .0155 11.05 .0048 12.06 .0077 13.00 .0020 14.10 .0083 15.15 .0084
- 16.18 .0015 17.22 .0039 18.27 .0032 19.34 .0026 20.40 .0012 21.47 .0009 22.54 .0008 23.62 .0016
- 24.71 .0005 25.82 .0004 26.91 .0002 28.03 .0008 29.17 .0002 30.32 .0028 31.45 .0004 32.61 .0005
- 33.77 .0001 36.14 .0003 37.32 .0002 38.54 .0005 39.75 .0002 42.23 .0002 48.65 .0001))
-
-(define p-d3 '( 1.01 .0423 1.99 .0240 2.98 .0517 4.00 .0493 5.00 .0324 6.00 .0094 6.99 .0449
- 7.99 .0050 9.00 .0197 10.03 .0132 11.03 .0009 12.07 .0017 13.08 .0023 14.12 .0094 15.16 .0071
- 16.21 .0020 17.25 .0005 18.30 .0027 19.04 .0004 20.43 .0022 21.51 .0002 22.59 .0006 23.72 .0018
- 24.80 .0002 25.88 .0002 27.03 .0002 28.09 .0006 29.31 .0002 30.46 .0004 31.61 .0007 32.78 .0005
- 33.95 .0001 36.34 .0002 37.56 .0001 38.80 .0001 40.02 .0001 44.14 .0001))
-
-(define p-ds3 '( 1.00 .0669 1.99 .0909 2.99 .0410 3.98 .0292 4.98 .0259 5.98 .0148 6.98 .0319
- 7.99 .0076 9.01 .0056 10.02 .0206 11.04 .0032 12.05 .0085 13.08 .0040 14.12 .0037 15.16 .0030
- 16.20 .0013 17.24 .0021 18.30 .0010 19.36 .0015 20.44 .0013 21.50 .0009 22.60 .0015 23.69 .0014
- 24.80 .0006 25.87 .0002 27.02 .0006 28.12 .0002 29.28 .0003 30.43 .0002 31.59 .0007 32.79 .0001
- 35.14 .0001 37.57 .0001 40.03 .0002 41.28 .0004 44.10 .0001))
-
-(define p-e3 '( .99 .0421 1.99 .1541 2.98 .0596 3.98 .0309 4.98 .0301 5.99 .0103 7.00 .0240
- 8.01 .0073 9.01 .0222 10.04 .0140 11.05 .0033 12.08 .0045 13.13 .0009 14.13 .0015 15.21 .0026
- 16.24 .0003 17.30 .0004 18.35 .0010 19.39 .0003 20.50 .0015 21.57 .0003 22.68 .0011 23.80 .0005
- 24.90 .0008 26.02 .0002 27.16 .0001 28.30 .0006 29.48 .0002 31.81 .0005 33.00 .0003 34.21 .0001
- 37.89 .0001))
-
-(define p-f3 '( .99 .0389 2.00 .2095 3.00 .0835 3.99 .0289 5.00 .0578 5.99 .0363 7.01 .0387
- 8.01 .0056 9.04 .0173 10.05 .0175 11.08 .0053 12.10 .0056 13.15 .0064 14.19 .0036 15.22 .0019
- 16.29 .0010 17.36 .0017 18.43 .0018 19.51 .0004 20.60 .0011 21.70 .0003 22.82 .0003 23.95 .0001
- 25.05 .0004 26.17 .0001 28.50 .0003 29.68 .0001 32.07 .0003 33.28 .0004 34.52 .0001))
-
-(define p-fs3 '( 1.00 .1238 1.99 .2270 3.00 .0102 3.99 .0181 4.98 .0415 6.00 .0165 7.01 .0314
- 8.02 .0148 9.04 .0203 10.05 .0088 11.07 .0062 12.11 .0070 13.14 .0054 14.19 .0028 15.24 .0044
- 16.30 .0029 17.38 .0009 18.45 .0026 19.56 .0003 20.65 .0025 21.74 .0014 22.87 .0013 23.99 .0007
- 25.15 .0002 27.46 .0004 28.39 .0006 28.65 .0004 29.85 .0001 31.05 .0002 32.27 .0003 33.52 .0002
- 34.76 .0003))
-
-(define p-g3 '( 1.00 .1054 2.00 .2598 2.99 .0369 3.98 .0523 4.99 .0020 5.99 .0051 7.00 .0268
- 8.01 .0027 9.04 .0029 10.05 .0081 11.08 .0047 12.12 .0051 13.16 .0091 14.19 .0015 15.27 .0030
- 16.34 .0017 17.42 .0006 18.51 .0003 19.61 .0007 20.72 .0003 21.84 .0001 22.99 .0010 24.13 .0001
- 28.44 .0001 30.09 .0001))
-
-(define p-gs3 '( .99 .0919 2.00 .0418 2.99 .0498 3.99 .0135 4.99 .0026 6.00 .0155 7.01 .0340
- 8.02 .0033 9.04 .0218 10.08 .0084 11.11 .0057 12.15 .0051 13.21 .0043 14.25 .0015 15.31 .0023
- 16.40 .0008 17.48 .0004 18.59 .0016 19.71 .0010 20.84 .0018 21.98 .0002 23.11 .0013 24.26 .0003
- 26.67 .0002 29.12 .0002 30.37 .0002 31.62 .0003 32.92 .0001))
-
-(define p-a3 '( .99 .1174 1.99 .1126 2.99 .0370 3.99 .0159 5.01 .0472 6.01 .0091 7.03 .0211
- 8.05 .0015 9.07 .0098 10.11 .0038 11.15 .0042 12.20 .0018 13.24 .0041 14.32 .0033 15.41 .0052
- 16.49 .0001 17.61 .0004 18.71 .0004 19.84 .0004 20.99 .0002 22.14 .0006 23.31 .0006 24.50 .0004
- 25.70 .0002 28.09 .0002 28.66 .0002 32.00 .0001))
-
-(define p-as3 '( 1.00 .1085 2.00 .1400 2.99 .0173 3.99 .0229 5.00 .0272 6.02 .0077 7.03 .0069
- 8.04 .0017 9.08 .0045 10.10 .0030 11.15 .0040 12.20 .0007 13.25 .0019 14.32 .0008 15.42 .0024
- 16.50 .0002 17.59 .0005 18.71 .0003 19.83 .0002 20.98 .0005 23.29 .0008))
-
-(define p-b3 '( 1.00 .0985 2.00 .1440 2.99 .0364 3.99 .0425 5.00 .0190 6.01 .0089 7.03 .0278
- 8.04 .0006 9.07 .0083 10.10 .0021 11.14 .0050 12.18 .0005 13.26 .0036 14.33 .0005 15.41 .0026
- 17.62 .0004 18.75 .0004 19.89 .0003 21.04 .0012 22.21 .0002 23.38 .0004 27.04 .0001))
-
-(define p-c4 '( .99 .1273 2.00 .1311 2.99 .0120 4.00 .0099 5.00 .0235 6.02 .0068 7.03 .0162
- 8.06 .0009 9.08 .0083 10.12 .0014 11.17 .0050 12.24 .0010 13.29 .0013 14.39 .0022 15.48 .0011
- 16.59 .0002 17.70 .0003 18.84 .0010 20.00 .0003 21.17 .0003 23.56 .0004 28.79 .0003))
-
-(define p-cs4 '( 1.00 .1018 2.00 .1486 3.00 .0165 4.00 .0186 5.01 .0194 6.02 .0045 7.04 .0083
- 8.06 .0012 9.10 .0066 10.15 .0009 11.19 .0008 12.26 .0011 13.34 .0028 14.45 .0006 15.53 .0009
- 16.66 .0002 17.79 .0006 18.94 .0005 20.11 .0003 21.29 .0005 22.49 .0003 23.73 .0005 26.22 .0001
- 27.52 .0001 28.88 .0002))
-
-(define p-d4 '( 1.00 .1889 1.99 .1822 3.00 .0363 4.00 .0047 5.01 .0202 6.03 .0053 7.05 .0114
- 8.01 .0002 9.13 .0048 10.17 .0010 11.23 .0033 12.30 .0010 13.38 .0006 14.50 .0002 15.62 .0010
- 20.27 .0001 21.47 .0001))
-
-(define p-ds4 '( 1.00 .0522 1.99 .0763 2.99 .0404 4.00 .0139 5.01 .0185 6.01 .0021 7.06 .0045
- 8.09 .0002 9.11 .0003 10.17 .0006 11.25 .0004 12.32 .0005 13.40 .0003 14.53 .0003 15.65 .0007
- 16.80 .0001 17.95 .0002 19.14 .0006 20.34 .0002 21.56 .0003))
-
-(define p-e4 '( .99 .1821 1.99 .0773 3.00 .0125 4.01 .0065 5.01 .0202 6.03 .0071 7.05 .0090
- 8.08 .0006 9.13 .0008 10.18 .0013 11.25 .0010 12.33 .0012 13.42 .0006 14.54 .0005 15.65 .0004
- 17.97 .0002 19.15 .0001))
-
-(define p-f4 '( 1.00 .1868 2.00 .0951 3.00 .0147 4.01 .0134 5.02 .0184 6.04 .0132 7.06 .0011
- 8.11 .0008 9.15 .0010 10.22 .0012 11.30 .0011 12.40 .0003 13.11 .0004 13.49 .0002 14.62 .0003
- 15.77 .0001))
-
-(define p-fs4 '( 1.00 .1933 2.00 .0714 3.00 .0373 4.00 .0108 5.02 .0094 6.02 .0010 7.07 .0022
- 8.11 .0002 9.16 .0065 10.23 .0015 11.31 .0023 12.40 .0003 13.53 .0014 14.66 .0002 15.81 .0011
- 18.20 .0002 19.41 .0001))
-
-(define p-g4 '( .99 .2113 1.99 .0877 3.00 .0492 4.01 .0094 5.02 .0144 6.04 .0103 7.07 .0117
- 8.12 .0006 9.19 .0019 10.25 .0007 11.35 .0017 12.45 .0010 13.58 .0003 14.74 .0003 15.91 .0003
- 19.57 .0002))
-
-(define p-gs4 '( .99 .2455 1.99 .0161 3.00 .0215 4.01 .0036 5.03 .0049 6.04 .0012 7.09 .0036
- 8.14 .0011 9.21 .0009 10.30 .0001 11.40 .0012 12.50 .0001 13.66 .0005 14.84 .0001))
-
-(define p-a4 '( 1.00 .1132 2.00 .0252 3.00 .0292 4.01 .0136 5.03 .0045 6.06 .0022 7.11 .0101
- 8.17 .0004 9.23 .0010 10.33 .0012 11.44 .0013 12.58 .0011 13.75 .0002 14.93 .0005 16.14 .0002))
-
-(define p-as4 '( 1.00 .1655 2.00 .0445 3.00 .0120 4.00 .0038 5.02 .0015 6.07 .0038 7.11 .0003
- 8.19 .0002 9.25 .0010 10.36 .0011 11.48 .0005 12.63 .0002 13.79 .0003 16.24 .0002))
-
-(define p-b4 '( .99 .3637 1.99 .0259 3.01 .0038 4.01 .0057 5.03 .0040 6.07 .0067 7.12 .0014
- 8.19 .0004 9.27 .0003 10.38 .0002 12.67 .0001))
-
-(define p-c5 '( 1.00 .1193 2.00 .0230 3.00 .0104 4.01 .0084 5.04 .0047 6.08 .0035 7.13 .0041
- 8.20 .0002 9.29 .0005 10.40 .0005 11.53 .0003 12.70 .0002 13.91 .0002))
-
-(define p-cs5 '( 1.00 .0752 2.00 .0497 3.00 .0074 4.02 .0076 5.05 .0053 6.09 .0043 7.15 .0024
- 8.22 .0001 9.32 .0006 10.45 .0002 11.58 .0001 12.78 .0001 15.22 .0001))
-
-(define p-d5 '( 1.00 .2388 2.00 .0629 3.01 .0159 4.04 .0063 5.07 .0051 6.12 .0045 7.19 .0026
- 8.29 .0015 9.43 .0001 11.75 .0002))
-
-(define p-ds5 '( 1.00 .1919 2.01 .0116 3.01 .0031 4.03 .0090 5.07 .0061 6.13 .0036 7.19 .0013
- 8.30 .0016 9.13 .0001 10.59 .0002 11.78 .0002))
-
-(define p-e5 '( 1.00 .1296 2.00 .0135 3.01 .0041 4.04 .0045 5.09 .0028 6.14 .0046 7.23 .0007
- 8.32 .0007 9.50 .0001))
-
-(define p-f5 '( 1.00 .0692 2.00 .0209 3.02 .0025 4.05 .0030 5.09 .0047 6.17 .0022 7.25 .0015
- 8.36 .0015 9.53 .0010 10.69 .0001 13.40 .0001))
-
-(define p-fs5 '( 1.00 .1715 2.00 .0142 3.01 .0024 4.03 .0015 5.07 .0017 6.13 .0018 7.22 .0009
- 8.33 .0014 9.51 .0007 10.69 .0002))
-
-(define p-g5 '( 1.00 .1555 2.01 .0148 3.02 .0007 4.06 .0006 5.10 .0005 6.16 .0008 7.26 .0009
- 8.39 .0008 9.58 .0002))
-
-(define p-gs5 '( 1.00 .1357 2.00 .0116 3.02 .0026 4.04 .0009 5.09 .0004 6.17 .0005 7.27 .0002
- 8.40 .0001))
-
-(define p-a5 '( 1.00 .2185 2.01 .0087 3.03 .0018 4.06 .0025 5.11 .0020 6.20 .0012 7.32 .0005
- 8.46 .0001 9.66 .0003))
-
-(define p-as5 '( 1.00 .2735 2.00 .0038 3.02 .0008 4.06 .0012 5.12 .0008 6.22 .0011 7.35 .0003
- 8.50 .0002))
-
-(define p-b5 '( 1.00 .1441 1.99 .0062 3.01 .0023 4.05 .0011 5.11 .0012 6.20 .0003 7.33 .0004
- 8.50 .0001))
-
-(define p-c6 '( 1.00 .0726 2.01 .0293 3.03 .0022 5.14 .0005 6.26 .0011 7.41 .0002 8.63 .0002))
-
-(define p-cs6 '( 1.00 .0516 2.00 .0104 3.02 .0029 5.15 .0002 6.27 .0001))
-
-(define p-d6 '( 1.00 .0329 2.00 .0033 3.03 .0013 4.10 .0005 5.19 .0004 6.32 .0002))
-
-(define p-ds6 '( 1.00 .0179 1.99 .0012 3.04 .0005 4.10 .0017 5.20 .0005 6.35 .0001))
-
-(define p-e6 '( 1.00 .0334 2.01 .0033 3.04 .0011 4.13 .0003 5.22 .0003))
-
-(define p-f6 '( .99 .0161 2.01 .0100 3.04 .0020 4.13 .0003))
-
-(define p-fs6 '( 1.00 .0475 1.99 .0045 3.03 .0035 4.12 .0011))
-
-(define p-g6 '( 1.00 .0593 2.00 .0014 4.17 .0002))
-
-(define p-gs6 '( 1.00 .0249 2.01 .0016))
-
-(define p-a6 '( 1.00 .0242 2.00 .0038 4.19 .0002))
-
-(define p-as6 '( 1.00 .0170 2.02 .0030))
-
-(define p-b6 '( 1.00 .0381 2.00 .0017 3.09 .0002))
-
-(define p-c7 '( 1.00 .0141 2.03 .0005 3.11 .0003 4.26 .0001))
-
-(define p-cs7 '( 1.00 .0122 2.03 .0024))
-
-(define p-d7 '( 1.00 .0107 2.07 .0007 3.12 .0004))
-
-(define p-ds7 '( 1.00 .0250 2.02 .0026 3.15 .0002))
-
-(define p-e7 '( 1.01 .0092))
-
-(define p-f7 '( 1.01 .0102 2.09 .0005))
-
-(define p-fs7 '( 1.00 .0080 2.00 .0005 3.19 .0001))
-
-(define p-g7 '( 1.01 .0298 2.01 .0005))
-
-;;;
-;;;
-;;;
-;;;
-;;; sax
-(define sax-cs3 '( 1.01 .0565 2.01 .0374 3.00 .0377 4.00 .0498 5.02 .0907 6.02 .0361 7.02 .0250
- 8.01 .0036 9.02 .0181 10.03 .0319 11.03 .0075 12.03 .0068 13.03 .0037 14.03 .0015 15.05 .0021
- 16.04 .0034 17.04 .0076 18.04 .0101 19.06 .0056 20.06 .0051 21.05 .0046 22.05 .0029 23.05 .0015
- 24.07 .0026 25.07 .0023 26.06 .0025 27.06 .0010 28.08 .0011 29.08 .0005 30.07 .0017 31.07 .0025
- 32.07 .0032 33.09 .0026 34.09 .0023 35.09 .0038 36.09 .0023 37.09 .0018 38.11 .0023 39.11 .0017
- 40.10 .0015 41.10 .0010 42.10 .0008 43.13 .0004 45.13 .0001 46.11 .0005 47.12 .0004 48.12 .0006
- 49.11 .0004 50.12 .0008 51.13 .0006 52.14 .0009 53.13 .0006 54.13 .0008 55.13 .0007 56.15 .0005
- 57.16 .0002 58.13 .0001 59.17 .0001 61.15 .0001 62.15 .0002 63.16 .0002 65.17 .0004 66.18 .0005
- 67.18 .0003 68.17 .0002 69.17 .0005 70.18 .0003 71.18 .0002 72.18 .0005 73.18 .0003 74.18 .0003
- 75.20 .0003 76.19 .0003 77.19 .0002 78.19 .0004 80.20 .0002 81.19 .0001 82.21 .0001 89.23 .0002
- 90.23 .0002 91.23 .0003 92.22 .0001))
-
-(define sax-d3 '( 1.00 .0423 1.99 .0487 2.98 .0259 3.99 .0630 4.99 .1026 5.97 .0532 6.97 .0259
- 7.98 .0110 8.97 .0076 9.96 .0123 10.97 .0162 11.96 .0128 12.95 .0178 13.94 .0114 14.96 .0134
- 15.95 .0186 16.94 .0180 17.93 .0087 18.94 .0084 19.93 .0064 20.92 .0033 21.93 .0025 22.93 .0041
- 23.91 .0041 24.90 .0034 25.91 .0012 26.90 .0013 27.90 .0020 28.89 .0036 29.90 .0054 30.89 .0054
- 31.88 .0038 32.89 .0059 33.89 .0037 34.88 .0024 35.86 .0024 36.87 .0023 37.87 .0017 38.86 .0020
- 39.85 .0019 40.86 .0021 41.86 .0007 42.84 .0012 43.84 .0007 44.84 .0010 45.85 .0005 46.82 .0006
- 47.84 .0009 48.82 .0009 49.82 .0006 50.81 .0008 51.82 .0012 52.80 .0012 54.81 .0005 55.78 .0003
- 56.79 .0003 57.78 .0003 58.79 .0003 59.80 .0004 60.77 .0003 61.78 .0004 62.77 .0005 63.77 .0001
- 64.75 .0004 65.76 .0003 66.77 .0003 67.76 .0006 68.75 .0006 69.75 .0007 70.74 .0004 71.74 .0010
- 72.73 .0008 73.74 .0007 75.74 .0002 76.72 .0004 77.72 .0002 78.71 .0004 79.70 .0001 80.71 .0001
- 81.70 .0002 82.70 .0001 83.70 .0004 84.69 .0003 85.68 .0008 86.68 .0003 87.69 .0001 88.69 .0002
- 90.66 .0001))
-
-(define sax-ds3 '( 1.00 .0338 1.99 .0765 2.97 .0602 3.96 .0870 4.97 .1666 5.96 .0394 6.95 .0067
- 7.94 .0199 8.94 .0418 9.93 .0110 10.92 .0101 11.91 .0077 12.90 .0052 13.91 .0148 14.90 .0172
- 15.88 .0218 16.87 .0110 17.88 .0086 18.87 .0045 19.86 .0009 20.85 .0014 21.85 .0045 22.84 .0037
- 23.83 .0010 24.82 .0028 25.81 .0013 26.82 .0032 27.81 .0040 28.79 .0067 29.78 .0035 30.79 .0041
- 31.78 .0028 32.76 .0017 33.75 .0011 34.76 .0015 35.75 .0018 36.73 .0021 37.72 .0017 38.71 .0019
- 39.72 .0014 40.71 .0015 41.70 .0016 42.69 .0006 43.69 .0021 44.69 .0024 45.67 .0003 46.66 .0014
- 47.66 .0002 48.66 .0011 49.65 .0010 50.63 .0002 51.62 .0008 52.63 .0007 53.62 .0008 54.60 .0004
- 56.59 .0005 57.59 .0003 58.58 .0007 60.56 .0004 61.56 .0002 62.55 .0004 63.54 .0004 64.53 .0008
- 65.54 .0011 66.53 .0003 67.52 .0009 68.51 .0008 69.51 .0013 70.50 .0002 71.49 .0004 72.47 .0004
- 73.47 .0002 74.48 .0002 75.46 .0002 76.45 .0005 77.45 .0003 78.45 .0008 79.44 .0003 80.42 .0008
- 81.41 .0005 82.41 .0001 83.42 .0001))
-
-(define sax-e3 '( 1.00 .0225 1.99 .0627 2.99 .0834 3.98 .0804 4.98 .0984 5.97 .0393 6.96 .0345
- 7.96 .0102 8.95 .0084 9.94 .0129 10.93 .0214 11.93 .0154 12.92 .0184 13.91 .0167 14.91 .0213
- 15.90 .0116 16.89 .0090 17.88 .0045 18.88 .0008 19.87 .0024 20.86 .0045 21.86 .0058 22.85 .0012
- 23.84 .0012 24.84 .0030 25.83 .0035 26.82 .0067 27.83 .0048 28.82 .0016 29.82 .0012 30.81 .0015
- 31.81 .0032 32.80 .0033 33.80 .0038 34.79 .0032 35.78 .0025 36.78 .0008 37.77 .0007 38.76 .0020
- 39.75 .0009 40.75 .0007 41.74 .0018 42.73 .0024 43.72 .0012 44.72 .0016 45.71 .0015 46.70 .0019
- 47.69 .0005 48.69 .0007 49.68 .0006 50.67 .0003 51.68 .0006 52.67 .0002 53.66 .0004 54.65 .0004
- 55.65 .0005 56.64 .0004 57.64 .0006 58.64 .0004 59.64 .0004 60.63 .0011 61.62 .0004 62.62 .0003
- 63.61 .0005 64.60 .0011 65.60 .0010 65.74 .0001 66.59 .0001 67.58 .0006 68.57 .0007 69.56 .0003
- 70.56 .0002 71.56 .0002 72.55 .0007 73.54 .0009 74.53 .0008 75.52 .0007 76.52 .0006 77.51 .0002
- 79.50 .0002))
-
-(define sax-f3 '( .98 .0394 1.98 .0562 2.97 .0897 3.96 .0683 4.96 .0231 5.95 .0309 6.94 .0308
- 7.91 .0176 8.91 .0089 9.90 .0084 10.89 .0141 11.89 .0045 12.88 .0070 13.87 .0083 14.85 .0142
- 15.84 .0089 16.83 .0048 17.82 .0015 18.82 .0028 19.82 .0027 20.81 .0015 21.79 .0012 22.77 .0015
- 23.76 .0050 24.76 .0041 25.75 .0048 26.75 .0015 27.74 .0007 28.73 .0011 29.71 .0016 30.70 .0020
- 31.69 .0019 32.68 .0032 33.68 .0026 34.67 .0014 35.66 .0013 36.64 .0009 37.63 .0014 38.62 .0009
- 39.61 .0018 40.61 .0008 41.60 .0013 42.59 .0007 43.57 .0010 44.56 .0006 45.57 .0002 46.54 .0009
- 47.53 .0005 48.51 .0002 49.53 .0001 50.52 .0005 51.49 .0002 52.49 .0006 53.47 .0001 54.48 .0002
- 55.46 .0003 56.47 .0002 57.45 .0006 58.43 .0004 59.42 .0003 60.41 .0006 61.41 .0005 62.40 .0005
- 63.40 .0002 64.38 .0003 65.37 .0001 66.35 .0002 68.34 .0005 69.33 .0003 70.33 .0005 71.32 .0001
- 72.30 .0002 75.27 .0001))
-
-(define sax-fs3 '( .99 .0784 1.99 .0550 2.97 .0439 3.97 .0998 4.95 .0679 5.95 .0244 6.93 .0178
- 7.94 .0130 8.92 .0186 9.92 .0204 10.90 .0091 11.90 .0102 12.88 .0166 13.88 .0130 14.86 .0079
- 15.86 .0039 16.86 .0023 17.84 .0052 18.84 .0049 19.82 .0042 20.82 .0027 21.81 .0027 22.80 .0057
- 23.78 .0042 24.79 .0042 25.77 .0015 26.77 .0008 27.75 .0020 28.75 .0021 29.73 .0032 30.73 .0036
- 31.71 .0022 32.71 .0011 33.71 .0015 34.69 .0011 35.69 .0012 36.67 .0013 37.67 .0014 38.65 .0006
- 39.65 .0013 40.64 .0004 41.63 .0010 42.62 .0002 43.62 .0010 44.60 .0003 45.59 .0003 46.58 .0004
- 47.59 .0005 48.57 .0002 49.55 .0005 50.55 .0002 51.54 .0002 52.53 .0005 53.53 .0006 54.52 .0006
- 55.51 .0002 56.50 .0008 57.47 .0003 58.48 .0007 59.47 .0003 60.46 .0002 61.44 .0002 62.45 .0002
- 63.43 .0001 64.43 .0004 65.42 .0005 66.41 .0007 67.40 .0002 68.39 .0002 69.39 .0002 70.37 .0001))
-
-(define sax-g3 '( 1.00 .1076 1.99 .0463 2.98 .1092 3.97 .0816 4.95 .0831 5.94 .0118 6.93 .0095
- 7.94 .0104 8.93 .0148 9.92 .0144 10.91 .0117 11.90 .0196 12.89 .0153 13.88 .0107 14.87 .0052
- 15.86 .0033 16.86 .0058 17.85 .0042 18.83 .0013 19.83 .0029 20.82 .0067 21.81 .0040 22.80 .0057
- 23.79 .0022 24.79 .0019 25.78 .0009 26.78 .0017 27.76 .0025 28.76 .0024 29.74 .0020 30.73 .0011
- 31.72 .0010 32.73 .0007 33.72 .0013 34.70 .0019 35.69 .0017 36.69 .0011 37.67 .0006 38.67 .0008
- 39.67 .0005 40.66 .0005 41.65 .0011 42.64 .0003 43.63 .0004 44.62 .0007 45.60 .0007 46.60 .0006
- 47.59 .0006 48.59 .0003 49.59 .0007 50.57 .0006 51.57 .0007 52.55 .0003 53.54 .0008 54.53 .0005
- 55.53 .0005 56.51 .0003 57.52 .0005 59.50 .0001 60.48 .0002 61.47 .0006 62.46 .0005 63.46 .0003
- 64.46 .0002 65.45 .0002))
-
-(define sax-gs3 '( .98 .0781 1.97 .0393 2.96 .0842 3.94 .0434 4.93 .0378 5.91 .0141 6.89 .0201
- 7.87 .0294 8.86 .0169 9.85 .0124 10.84 .0137 11.81 .0238 12.80 .0172 13.78 .0094 14.77 .0040
- 15.76 .0036 16.74 .0061 17.72 .0032 18.70 .0035 19.69 .0086 20.68 .0065 21.66 .0097 22.65 .0036
- 23.63 .0010 24.62 .0006 25.61 .0018 26.59 .0026 27.58 .0023 28.56 .0017 29.54 .0010 30.52 .0012
- 31.50 .0018 32.50 .0021 33.48 .0025 34.46 .0010 35.45 .0028 36.42 .0018 37.41 .0009 38.41 .0007
- 39.38 .0006 40.37 .0004 41.36 .0005 42.34 .0007 43.31 .0001 44.29 .0002 45.29 .0006 46.28 .0005
- 47.26 .0005 48.25 .0006 49.22 .0006 50.21 .0003 51.20 .0007 52.18 .0004 53.16 .0003 54.15 .0004
- 55.14 .0001 56.10 .0001 57.11 .0005 58.09 .0007 59.07 .0005 59.22 .0001 61.04 .0004 63.02 .0002))
-
-(define sax-a3 '( .99 .0950 1.97 .0374 2.95 .0738 3.94 .0772 4.93 .0103 5.92 .0135 6.90 .0099
- 7.88 .0088 8.88 .0151 9.86 .0150 10.84 .0177 11.83 .0121 12.82 .0071 13.81 .0049 14.79 .0025
- 15.77 .0046 16.77 .0023 17.75 .0020 18.73 .0079 19.71 .0057 20.70 .0068 21.69 .0036 22.67 .0007
- 23.65 .0003 24.65 .0006 25.64 .0016 26.62 .0013 27.60 .0006 28.59 .0005 29.59 .0005 30.56 .0013
- 31.55 .0015 32.53 .0013 33.52 .0009 34.51 .0016 35.48 .0002 36.47 .0007 37.46 .0002 38.46 .0003
- 39.43 .0002 40.42 .0003 41.40 .0006 42.40 .0006 43.39 .0002 44.36 .0009 45.35 .0008 46.34 .0010
- 47.32 .0003 48.30 .0009 49.29 .0006 50.28 .0002 51.27 .0004 52.25 .0002 54.23 .0003 55.21 .0001
- 56.19 .0002 58.17 .0002))
-
-(define sax-as3 '( .99 .0856 1.98 .0365 2.97 .0409 3.96 .0666 4.94 .0192 5.94 .0263 6.92 .0311
- 7.91 .0175 8.90 .0203 9.89 .0358 10.87 .0214 11.87 .0177 12.85 .0068 13.84 .0071 14.83 .0068
- 15.82 .0040 16.80 .0040 17.80 .0126 18.78 .0101 19.77 .0086 20.75 .0053 21.75 .0012 22.73 .0026
- 23.73 .0019 24.71 .0018 25.71 .0026 26.68 .0023 27.68 .0022 28.66 .0015 29.66 .0031 30.64 .0008
- 31.63 .0023 32.61 .0029 33.61 .0007 34.59 .0016 35.59 .0009 36.57 .0006 37.56 .0012 38.54 .0004
- 39.53 .0005 40.52 .0007 41.52 .0006 42.50 .0009 43.50 .0015 44.48 .0005 45.47 .0012 46.46 .0007
- 47.45 .0003 48.44 .0007 49.41 .0003 50.41 .0003 51.40 .0011 52.39 .0007 53.37 .0005 54.36 .0005
- 55.34 .0002 56.34 .0002))
-
-(define sax-b3 '( .99 .1015 1.99 .0817 2.98 .0315 3.98 .0386 4.97 .0424 5.96 .0104 6.96 .0144
- 7.94 .0361 8.94 .0182 9.93 .0238 10.93 .0139 11.93 .0063 12.91 .0058 13.91 .0071 14.91 .0051
- 15.89 .0035 16.90 .0114 17.88 .0097 18.88 .0081 19.87 .0043 20.86 .0014 21.86 .0009 22.85 .0012
- 23.86 .0006 24.84 .0013 25.83 .0006 26.83 .0010 27.82 .0015 28.80 .0008 29.80 .0012 30.80 .0017
- 31.77 .0002 32.78 .0016 33.78 .0006 34.77 .0003 35.77 .0009 36.76 .0006 37.75 .0011 38.75 .0006
- 39.74 .0011 40.74 .0011 41.73 .0006 42.72 .0015 43.72 .0008 44.70 .0002 45.71 .0005 46.70 .0004
- 47.69 .0003 48.69 .0005 49.67 .0005 50.64 .0001 51.66 .0003))
-
-(define sax-c4 '( .99 .1462 1.98 .0760 2.98 .0464 3.97 .0292 4.95 .0393 5.95 .0117 6.94 .0150
- 7.93 .0251 8.93 .0238 9.92 .0182 10.90 .0142 11.89 .0100 12.89 .0108 13.88 .0029 14.87 .0060
- 15.86 .0116 16.85 .0066 17.84 .0072 18.84 .0034 19.83 .0010 20.82 .0013 21.81 .0015 22.80 .0012
- 23.80 .0011 24.79 .0004 25.77 .0027 26.76 .0021 27.75 .0018 28.75 .0013 29.74 .0015 30.73 .0008
- 31.72 .0004 32.71 .0007 33.71 .0011 34.70 .0002 35.68 .0010 36.67 .0002 37.66 .0003 38.67 .0010
- 39.66 .0008 40.64 .0019 41.64 .0005 42.62 .0010 43.62 .0003 45.60 .0005 46.59 .0002 47.59 .0002
- 48.58 .0002 49.57 .0002 50.55 .0001))
-
-(define sax-cs4 '( .99 .0832 1.97 .0162 2.96 .0337 3.95 .0272 4.94 .0264 5.93 .0256 6.93 .0180
- 7.92 .0206 8.90 .0167 9.89 .0172 10.88 .0075 11.86 .0087 12.85 .0048 13.85 .0051 14.83 .0134
- 15.83 .0091 16.82 .0065 17.80 .0008 18.80 .0018 19.78 .0023 20.77 .0025 21.76 .0021 22.74 .0013
- 23.74 .0011 24.72 .0032 25.72 .0006 26.72 .0005 27.69 .0026 28.69 .0009 29.68 .0006 30.66 .0003
- 31.65 .0007 32.64 .0003 33.62 .0014 34.61 .0007 35.60 .0007 36.59 .0005 37.60 .0004 38.56 .0006
- 39.54 .0004 40.55 .0004 41.55 .0003 42.50 .0002 43.51 .0005 44.50 .0003 45.50 .0002 46.48 .0002
- 47.48 .0002))
-
-(define sax-d4 '( .98 .0860 1.97 .0143 2.95 .0061 3.94 .0407 4.93 .0204 5.91 .0066 6.90 .0372
- 7.89 .0217 8.87 .0220 9.86 .0147 10.85 .0042 11.83 .0072 12.82 .0023 13.81 .0074 14.79 .0104
- 15.78 .0050 16.76 .0005 17.74 .0036 18.73 .0056 19.71 .0022 20.70 .0040 21.69 .0021 22.68 .0018
- 23.66 .0026 24.65 .0035 25.64 .0021 26.62 .0011 27.61 .0013 28.59 .0006 29.58 .0002 30.57 .0010
- 31.69 .0001 32.54 .0004 33.52 .0009 34.50 .0005 35.49 .0004 36.47 .0013 37.46 .0015 38.45 .0009
- 39.43 .0003 40.42 .0004 41.41 .0008 42.40 .0005 43.38 .0004 44.37 .0006))
-
-(define sax-ds4 '( .98 .0870 1.97 .0204 2.96 .0184 3.94 .0494 4.92 .0500 5.91 .0163 6.90 .0267
- 7.88 .0158 8.86 .0159 9.85 .0095 10.84 .0095 11.82 .0039 12.81 .0053 13.79 .0074 14.78 .0054
- 15.77 .0004 16.75 .0027 17.73 .0034 18.71 .0035 19.70 .0019 20.69 .0028 21.67 .0032 22.65 .0016
- 23.64 .0018 24.63 .0033 25.61 .0006 26.59 .0015 27.58 .0005 28.57 .0010 29.56 .0006 30.54 .0010
- 31.52 .0009 32.51 .0004 33.50 .0012 34.47 .0006 35.46 .0009 36.45 .0007 37.44 .0002 38.42 .0006
- 39.41 .0003 40.38 .0003 41.38 .0005 42.36 .0003))
-
-(define sax-e4 '( .99 .0111 1.97 .0520 2.96 .0287 3.94 .0704 4.93 .0240 5.91 .0286 6.89 .0516
- 7.89 .0184 8.87 .0076 9.86 .0113 10.84 .0049 11.83 .0044 12.81 .0111 13.79 .0080 14.78 .0008
- 15.76 .0031 16.76 .0042 17.74 .0016 18.73 .0021 19.71 .0010 20.69 .0048 21.68 .0014 22.66 .0020
- 23.66 .0016 24.64 .0011 25.62 .0011 26.61 .0001 27.59 .0011 28.58 .0013 29.56 .0011 30.55 .0004
- 31.54 .0015 32.52 .0023 33.51 .0015 34.49 .0004 35.48 .0003 36.46 .0007 37.45 .0003 38.43 .0003
- 39.42 .0009))
-
-(define sax-f4 '( 1.00 .0896 2.00 .1802 3.00 .0636 4.00 .0344 5.01 .0214 6.01 .0196 7.01 .0241
- 8.01 .0118 9.01 .0057 10.01 .0060 11.01 .0059 12.01 .0032 13.02 .0055 14.02 .0023 15.01 .0020
- 16.02 .0027 17.02 .0022 18.02 .0017 19.02 .0015 20.02 .0020 21.03 .0014 22.03 .0010 23.02 .0006
- 24.03 .0007 25.03 .0005 27.03 .0006 28.03 .0005 29.04 .0003 30.04 .0009 31.03 .0006 32.04 .0003
- 33.04 .0002 34.04 .0003 35.04 .0001 36.04 .0002 37.05 .0003))
-
-(define sax-fs4 '( .99 .0786 1.99 .1613 2.99 .0550 3.98 .0380 4.98 .0201 5.98 .0245 6.97 .0212
- 7.96 .0069 8.96 .0130 9.96 .0029 10.95 .0084 11.95 .0093 12.94 .0026 13.94 .0015 14.93 .0022
- 15.93 .0025 16.93 .0022 17.92 .0015 18.91 .0011 19.91 .0011 20.91 .0006 21.90 .0010 22.89 .0003
- 23.89 .0003 24.89 .0004 25.89 .0003 26.88 .0011 26.95 .0003 27.87 .0003 28.87 .0012 29.87 .0002
- 30.86 .0004 31.85 .0003 32.85 .0005 33.84 .0006 34.84 .0002 34.90 .0001))
-
-(define sax-g4 '( 1.00 .0747 2.00 .1351 3.00 .0384 4.00 .0519 5.00 .0376 6.00 .0323 7.00 .0212
- 8.00 .0091 9.00 .0086 10.00 .0060 11.00 .0132 12.00 .0038 13.00 .0016 14.00 .0044 15.00 .0023
- 16.00 .0029 17.00 .0031 18.00 .0011 19.00 .0008 20.00 .0006 21.01 .0005 22.00 .0006 23.00 .0007
- 24.00 .0008 25.01 .0003 26.01 .0017 27.00 .0012 28.00 .0005 29.03 .0001 30.00 .0004 31.00 .0005
- 32.00 .0001 33.00 .0003 34.00 .0001))
-
-(define sax-gs4 '( 1.00 .0671 1.99 .0676 2.98 .0664 3.97 .0207 4.97 .0170 5.96 .0406 6.96 .0157
- 7.95 .0093 8.94 .0032 9.93 .0117 10.93 .0059 11.93 .0034 12.92 .0052 13.91 .0036 14.90 .0010
- 15.89 .0023 16.89 .0019 17.89 .0011 18.88 .0013 19.87 .0009 20.86 .0005 21.86 .0006 22.86 .0011
- 23.85 .0006 24.85 .0008 25.83 .0010 26.83 .0010 27.82 .0007 28.80 .0002 29.82 .0006 31.80 .0001))
-
-(define sax-a4 '( .99 .0707 1.99 .1376 2.99 .0767 3.98 .0191 4.98 .0316 5.97 .0241 6.97 .0070
- 7.97 .0095 8.96 .0085 9.96 .0109 10.96 .0012 11.95 .0047 12.94 .0051 13.94 .0022 14.93 .0020
- 15.93 .0007 16.93 .0016 17.92 .0014 18.92 .0008 19.92 .0005 20.91 .0008 21.91 .0005 22.91 .0002
- 23.90 .0008 24.89 .0015 25.89 .0004 26.89 .0003 27.88 .0002 28.88 .0002 29.88 .0002))
-
-(define sax-as4 '( .99 .0652 1.98 .0768 2.97 .0399 3.96 .0314 4.95 .0539 5.94 .0282 6.93 .0048
- 7.93 .0059 8.91 .0163 9.90 .0039 10.89 .0052 11.88 .0086 12.87 .0025 13.86 .0011 14.85 .0069
- 15.84 .0006 16.84 .0018 17.82 .0008 18.80 .0004 19.81 .0004 20.78 .0002 21.79 .0010 22.78 .0038
- 23.76 .0018 24.75 .0010 25.74 .0002 26.73 .0005 27.72 .0006 28.71 .0003))
-
-(define sax-b4 '( 1.00 .1365 1.99 .0773 2.98 .0370 3.97 .0399 4.97 .0441 5.96 .0193 6.95 .0055
- 7.95 .0036 8.94 .0106 9.93 .0050 10.93 .0075 11.92 .0047 12.91 .0013 13.90 .0034 14.90 .0024
- 15.89 .0018 16.89 .0005 17.87 .0006 18.87 .0014 19.87 .0011 20.86 .0017 21.84 .0018 22.84 .0007
- 23.83 .0003 24.82 .0006 25.83 .0002 26.81 .0002))
-
-(define sax-c5 '( .99 .1197 1.98 .0661 2.97 .0448 3.96 .0398 4.96 .0311 5.95 .0167 6.93 .0068
- 7.93 .0249 8.92 .0065 9.91 .0104 10.90 .0081 11.89 .0032 12.88 .0060 13.87 .0037 14.86 .0020
- 15.86 .0008 16.84 .0005 17.84 .0025 18.83 .0010 19.81 .0020 20.81 .0017 21.80 .0013 22.79 .0016
- 23.78 .0009 24.77 .0006 25.76 .0002))
-
-(define sax-cs5 '( .98 .0251 1.97 .0316 2.95 .0599 3.93 .0403 4.92 .0418 5.90 .0065 6.89 .0047
- 7.86 .0085 8.85 .0061 9.84 .0097 10.82 .0033 10.87 .0006 12.26 .0004 12.78 .0040 13.77 .0023
- 14.75 .0020 15.73 .0003 16.72 .0011 17.71 .0012 18.69 .0013 19.67 .0008 20.66 .0013 21.64 .0005
- 22.62 .0004 23.60 .0005))
-
-(define sax-d5 '( .99 .0055 1.97 .0823 2.95 .0106 3.94 .0646 4.93 .0345 5.91 .0069 6.90 .0201
- 7.89 .0165 8.87 .0171 9.86 .0114 10.85 .0050 11.82 .0053 12.82 .0107 13.81 .0033 14.78 .0026
- 15.78 .0016 16.76 .0019 17.74 .0011 18.72 .0030 19.73 .0009 20.70 .0021 21.67 .0003 22.67 .0003
- 23.65 .0001))
-
-(define sax-ds5 '( .98 .0699 1.97 .0761 2.95 .0777 3.93 .0573 4.92 .0236 5.90 .0082 6.88 .0195
- 7.87 .0108 8.85 .0205 9.83 .0042 10.82 .0112 11.80 .0039 12.78 .0018 13.77 .0027 14.75 .0017
- 15.73 .0015 16.72 .0019 17.70 .0047 18.68 .0011 19.67 .0020 20.65 .0027 21.63 .0002))
-
-(define sax-e5 '( .99 .1082 1.99 .1222 2.99 .0874 3.98 .0436 4.98 .0208 5.98 .0141 6.97 .0193
- 7.97 .0172 8.97 .0118 9.96 .0082 10.96 .0133 11.96 .0062 12.95 .0058 13.95 .0013 14.94 .0017
- 15.94 .0029 16.94 .0032 17.93 .0006 18.93 .0028 19.92 .0004))
-
-(define sax-f5 '( 1.00 .1462 2.00 .0665 3.01 .0741 4.01 .0382 5.01 .0262 6.02 .0172 7.02 .0168
- 8.02 .0172 9.02 .0087 10.02 .0145 11.03 .0046 12.03 .0033 13.03 .0032 14.03 .0030 15.03 .0040
- 16.04 .0059 17.04 .0026 18.04 .0005 19.05 .0009))
-
-(define sax-fs5 '( 1.00 .0652 2.00 .0563 3.00 .0939 3.99 .0334 5.00 .0109 5.99 .0258 6.99 .0213
- 7.99 .0135 8.99 .0018 9.99 .0205 10.99 .0043 11.99 .0004 12.99 .0037 13.98 .0017 14.98 .0071
- 15.98 .0035 16.98 .0029 17.98 .0005))
-
-(define sax-g5 '( 1.00 .0918 1.99 .0493 2.99 .0565 3.98 .0225 4.98 .0118 5.98 .0184 6.97 .0138
- 7.99 .0042 8.98 .0077 9.95 .0104 10.96 .0018 11.94 .0022 12.98 .0061 13.96 .0032 14.96 .0023
- 15.96 .0016 16.90 .0008))
-
-(define sax-gs5 '( .99 .1447 1.98 .0908 2.97 .0522 3.96 .0607 4.96 .0316 5.95 .0115 6.94 .0147
- 7.93 .0148 8.92 .0221 9.91 .0097 10.90 .0087 11.90 .0078 12.89 .0127 13.88 .0042 14.87 .0007
- 15.86 .0012))
-
-(define sax-a5 '( .97 .1089 1.94 .0491 4.85 .0162 5.82 .0156 6.78 .0130 7.75 .0174 8.72 .0104
- 8.75 .0087 8.77 .0024 8.80 .0019 8.82 .0014 9.72 .0010 10.66 .0033 11.63 .0092 11.66 .0045
- 12.59 .0028 12.65 .0015 12.67 .0011 13.64 .0007 14.56 .0017 14.59 .0017 14.61 .0010 14.62 .0008
- 14.64 .0005 15.50 .0003 15.53 .0002 15.56 .0002 15.58 .0001))
-
-
-;;;
-;;;
-;;;
-;;;
-;;; soprano sax?
-(define ssax-gs3 '( 1.01 .0846 2.02 .0851 3.03 .0782 4.03 .0250 5.04 .0513 6.05 .0121 7.07 .0065
- 8.08 .0409 9.09 .0134 10.09 .0032 11.10 .0168 12.12 .0076 13.13 .0054 14.13 .0091 15.14 .0078
- 16.15 .0029 17.16 .0103 18.18 .0103 19.18 .0071 20.19 .0105 21.20 .0063 22.20 .0054 23.21 .0011
- 24.22 .0008 25.24 .0003 26.23 .0001 27.26 .0002 28.25 .0006 29.27 .0004 30.29 .0008 31.29 .0004
- 32.31 .0002 33.32 .0003 34.32 .0003 35.33 .0001 36.34 .0002 37.35 .0005 38.36 .0003 39.37 .0003
- 40.37 .0002 41.39 .0002 42.40 .0002 43.41 .0002 44.43 .0001 45.43 .0007 46.43 .0004 47.44 .0002
- 48.46 .0001 49.48 .0001 50.48 .0002 51.49 .0002 52.49 .0002 53.50 .0002 54.51 .0002 55.53 .0003
- 56.54 .0003 57.54 .0002 58.55 .0002 59.55 .0001))
-
-(define ssax-a3 '( .99 .1143 1.99 .0599 2.99 .0780 3.99 .0629 4.99 .0063 5.99 .0066 6.99 .0283
- 7.99 .0134 8.98 .0083 9.97 .0114 10.97 .0087 11.97 .0171 12.97 .0109 13.97 .0149 14.97 .0075
- 15.97 .0164 16.97 .0174 17.94 .0021 18.97 .0139 19.96 .0073 20.95 .0122 21.95 .0018 22.95 .0022
- 23.94 .0002 24.95 .0014 25.94 .0006 26.95 .0007 27.94 .0012 28.94 .0013 29.93 .0009 30.94 .0014
- 31.92 .0012 32.93 .0008 33.93 .0015 34.93 .0021 35.92 .0009 36.93 .0011 37.93 .0011 38.94 .0005
- 39.92 .0008 41.93 .0004 42.91 .0012 43.87 .0002 44.93 .0006 45.92 .0006 46.91 .0002 47.92 .0002
- 48.91 .0004 49.89 .0004 50.89 .0003 51.89 .0003 52.90 .0003 53.90 .0003 54.91 .0003 55.90 .0003
- 56.89 .0002))
-
-(define ssax-as3 '( 1.00 .0772 1.99 .0797 2.98 .0350 3.99 .1086 4.98 .0418 5.97 .0170 6.98 .0247
- 7.97 .0288 8.96 .0041 9.95 .0047 10.95 .0120 11.95 .0176 12.93 .0128 13.95 .0151 14.94 .0162
- 15.92 .0152 16.93 .0077 17.93 .0111 18.92 .0092 19.91 .0079 20.91 .0053 21.89 .0009 22.90 .0008
- 24.88 .0004 25.88 .0009 26.88 .0009 27.87 .0014 28.87 .0008 29.87 .0023 30.87 .0013 31.85 .0012
- 32.87 .0015 33.85 .0011 34.85 .0024 35.84 .0021 36.86 .0024 37.87 .0008 38.82 .0007 39.85 .0009
- 40.79 .0007 41.83 .0009 42.84 .0007 43.84 .0006 44.82 .0001 46.83 .0004 47.83 .0003 48.81 .0003
- 49.82 .0002 50.82 .0001 51.82 .0002 52.81 .0002 54.81 .0004 55.80 .0002))
-
-(define ssax-b3 '( .99 .0413 1.98 .0949 2.98 .0746 3.96 .0636 4.96 .0383 5.95 .0300 6.93 .0190
- 7.93 .0159 8.92 .0172 9.90 .0159 10.90 .0047 11.89 .0087 12.88 .0153 13.87 .0129 14.87 .0112
- 15.85 .0054 16.84 .0076 17.84 .0060 18.82 .0064 19.81 .0050 20.81 .0009 21.80 .0013 22.78 .0003
- 23.79 .0005 24.78 .0005 25.76 .0020 26.75 .0020 27.75 .0016 28.73 .0012 29.72 .0009 30.72 .0017
- 31.70 .0018 32.69 .0012 33.69 .0022 34.67 .0014 35.67 .0015 36.66 .0009 37.65 .0013 38.64 .0019
- 39.63 .0010 40.62 .0012 41.61 .0003 42.61 .0003 43.60 .0003 44.58 .0004 45.58 .0003 47.55 .0004
- 48.54 .0002 49.54 .0003 50.53 .0002 51.52 .0002))
-
-(define ssax-c4 '( .99 .1251 1.98 .0932 2.97 .1614 3.97 .0801 4.96 .0100 5.94 .0183 6.94 .0221
- 7.93 .0060 8.92 .0055 9.91 .0162 10.90 .0171 11.89 .0181 12.88 .0135 13.88 .0102 14.87 .0071
- 15.86 .0066 16.84 .0071 17.83 .0057 18.83 .0027 19.82 .0006 20.82 .0008 21.80 .0003 22.78 .0007
- 23.78 .0011 24.77 .0019 25.77 .0010 26.76 .0016 27.74 .0008 28.74 .0013 29.73 .0025 30.72 .0019
- 31.71 .0029 32.70 .0022 33.69 .0011 34.68 .0014 35.68 .0010 36.67 .0014 37.65 .0007 38.64 .0005
- 39.62 .0001 40.63 .0004 41.62 .0006 42.61 .0005 43.60 .0003 44.58 .0003 45.58 .0003 46.58 .0006
- 47.57 .0003 48.56 .0002))
-
-(define ssax-cs4 '( .98 .0809 1.97 .0745 2.96 .1141 3.95 .0537 4.95 .0028 5.92 .0112 6.93 .0029
- 7.90 .0117 8.89 .0101 9.89 .0091 10.87 .0113 11.86 .0048 12.85 .0076 13.84 .0054 14.82 .0089
- 15.81 .0068 16.80 .0065 17.79 .0031 18.77 .0009 19.76 .0007 20.75 .0005 21.73 .0010 22.72 .0016
- 23.71 .0009 24.70 .0016 25.68 .0010 26.68 .0018 27.66 .0018 28.65 .0009 29.64 .0012 30.63 .0017
- 31.61 .0016 32.60 .0008 33.59 .0012 34.58 .0014 35.57 .0005 36.56 .0006 37.54 .0008 38.53 .0005
- 39.52 .0004 40.50 .0004 41.49 .0001 42.47 .0004 43.46 .0002))
-
-(define ssax-d4 '( .99 .0919 1.98 .0711 2.98 .0924 3.97 .0396 4.95 .0407 5.94 .0357 6.93 .0035
- 7.93 .0079 8.91 .0110 9.90 .0191 10.89 .0103 11.89 .0134 12.88 .0025 13.86 .0014 14.86 .0082
- 15.85 .0084 16.84 .0024 17.82 .0011 18.82 .0011 19.81 .0010 20.80 .0002 21.79 .0015 22.78 .0011
- 23.76 .0025 24.77 .0018 25.75 .0027 26.74 .0036 27.73 .0023 28.73 .0034 29.72 .0032 30.70 .0011
- 31.70 .0017 32.69 .0014 33.68 .0013 34.66 .0004 35.65 .0003 36.64 .0002 37.63 .0002 38.62 .0004
- 39.62 .0008 40.61 .0004 41.60 .0005 42.59 .0005 43.59 .0003 44.56 .0002))
-
-(define ssax-ds4 '( .99 .0684 1.98 .0744 2.97 .1315 3.96 .0137 4.94 .0352 5.94 .0195 6.93 .0148
- 7.91 .0275 8.91 .0191 9.90 .0268 10.88 .0194 11.86 .0044 12.86 .0046 13.85 .0090 14.84 .0072
- 15.83 .0049 16.82 .0015 17.80 .0017 18.80 .0006 19.79 .0008 20.77 .0020 21.76 .0010 22.75 .0025
- 23.74 .0033 24.73 .0023 25.72 .0041 26.71 .0051 27.70 .0043 28.69 .0033 29.68 .0010 30.66 .0013
- 31.65 .0013 32.64 .0013 33.63 .0008 34.64 .0001 35.61 .0002 36.60 .0003 37.62 .0002 38.58 .0006
- 39.57 .0005 40.58 .0001 41.55 .0002))
-
-(define ssax-e4 '( 1.00 .0363 1.98 .1101 2.98 .1009 3.96 .0168 4.95 .0610 5.95 .0099 6.94 .0066
- 7.93 .0157 8.92 .0162 9.91 .0154 10.90 .0131 11.89 .0061 12.88 .0029 13.87 .0058 14.86 .0040
- 15.85 .0015 16.84 .0012 17.84 .0005 18.82 .0005 19.81 .0008 20.85 .0007 21.80 .0005 22.78 .0016
- 23.77 .0017 24.76 .0022 25.76 .0010 26.80 .0006 27.74 .0012 28.72 .0007 29.71 .0004 30.70 .0004
- 31.69 .0001 32.68 .0001 33.67 .0003 34.65 .0004 35.65 .0003 36.64 .0003 37.63 .0002 38.61 .0002))
-
-(define ssax-f4 '( 1.00 .0607 1.99 .1291 3.00 .0576 3.99 .0530 4.99 .0330 5.98 .0364 6.98 .0116
- 7.98 .0252 8.97 .0175 9.97 .0166 10.97 .0147 11.97 .0096 12.96 .0060 13.96 .0022 14.95 .0018
- 15.95 .0018 16.96 .0003 17.94 .0012 18.94 .0021 19.94 .0051 20.94 .0018 21.93 .0034 22.93 .0038
- 23.93 .0035 24.92 .0041 25.92 .0015 26.91 .0024 27.92 .0019 28.92 .0008 29.91 .0005 30.92 .0003
- 31.91 .0005 32.91 .0006 33.90 .0003 34.89 .0002 35.89 .0005 36.89 .0002))
-
-(define ssax-fs4 '( .99 .0502 1.98 .0678 2.96 .0319 3.95 .0589 4.93 .0093 5.93 .0072 6.91 .0063
- 7.89 .0224 8.88 .0185 9.87 .0096 10.86 .0046 11.84 .0060 12.83 .0052 13.82 .0008 14.80 .0022
- 15.79 .0009 16.79 .0008 17.76 .0011 18.75 .0024 19.74 .0013 20.71 .0009 21.71 .0038 22.70 .0037
- 23.68 .0023 24.66 .0010 25.66 .0007 26.64 .0009 27.64 .0007 28.61 .0002 29.61 .0006 30.60 .0004
- 31.58 .0008 32.56 .0004 33.55 .0005 35.53 .0002))
-
-(define ssax-g4 '( 1.00 .0253 1.99 .0803 2.98 .0107 3.97 .0688 4.96 .0361 5.96 .0208 6.96 .0172
- 7.95 .0172 8.94 .0189 9.93 .0080 10.92 .0114 11.92 .0059 12.91 .0058 13.90 .0007 14.89 .0011
- 15.89 .0011 16.88 .0023 17.87 .0046 18.87 .0024 19.85 .0043 20.86 .0087 21.83 .0023 22.84 .0043
- 23.84 .0039 24.83 .0020 25.81 .0017 26.81 .0009 27.82 .0006 28.80 .0004 29.79 .0007 30.80 .0005
- 31.78 .0011 32.78 .0004 33.76 .0001))
-
-(define ssax-gs4 '( 1.00 .0453 2.00 .1198 2.99 .0370 3.99 .1319 4.98 .0327 5.97 .0018 6.98 .0199
- 7.97 .0362 8.97 .0196 9.96 .0065 10.96 .0061 11.96 .0025 12.95 .0026 13.95 .0010 14.94 .0005
- 15.94 .0027 16.94 .0031 17.93 .0037 18.92 .0019 19.92 .0034 20.92 .0087 21.92 .0034 22.91 .0029
- 23.91 .0024 24.90 .0006 25.90 .0002 26.90 .0009 27.90 .0003 28.90 .0015 29.89 .0011 30.89 .0004
- 31.88 .0001))
-
-(define ssax-a4 '( 1.00 .0568 1.99 .1275 2.98 .0496 3.98 .0504 4.97 .0277 5.96 .0064 6.95 .0205
- 7.95 .0244 8.94 .0067 9.93 .0133 10.92 .0045 11.92 .0035 12.91 .0028 13.90 .0010 14.90 .0011
- 15.89 .0035 16.89 .0034 17.88 .0037 18.87 .0052 19.86 .0027 20.86 .0028 21.86 .0003 22.84 .0011
- 23.84 .0005 24.83 .0010 25.82 .0005 26.81 .0003 27.81 .0007 28.80 .0005 29.79 .0004))
-
-(define ssax-as4 '( .99 .0497 1.98 .0814 2.97 .0351 3.96 .0207 4.95 .0068 5.93 .0241 6.92 .0219
- 7.91 .0187 8.90 .0053 9.88 .0026 10.88 .0026 11.87 .0027 12.85 .0011 13.85 .0018 14.84 .0029
- 15.84 .0013 16.83 .0014 17.81 .0036 18.80 .0042 19.79 .0015 20.78 .0021 21.77 .0018 22.76 .0011
- 23.75 .0004 24.66 .0003 25.73 .0006 26.72 .0005 27.71 .0002))
-
-(define ssax-b4 '( .99 .0161 1.98 .0825 2.96 .0846 3.95 .0304 4.94 .0112 5.93 .0158 6.91 .0362
- 7.90 .0085 8.89 .0147 9.87 .0047 10.85 .0016 11.85 .0044 12.84 .0024 13.83 .0044 14.82 .0015
- 15.80 .0066 16.79 .0061 17.78 .0135 18.77 .0107 19.75 .0020 20.75 .0008 21.73 .0010 22.71 .0014
- 23.70 .0007 24.69 .0009 25.68 .0008 26.67 .0002))
-
-(define ssax-c5 '( 1.00 .1378 1.99 .1932 2.99 .0181 3.98 .0213 4.97 .0472 5.97 .0302 6.97 .0099
- 7.96 .0039 8.96 .0052 9.95 .0031 10.95 .0007 11.94 .0010 12.93 .0015 13.93 .0009 14.93 .0013
- 15.92 .0018 16.92 .0015 17.91 .0030 18.91 .0013 19.90 .0008 20.90 .0008 21.89 .0006 22.89 .0006
- 23.89 .0003))
-
-(define ssax-cs5 '( .99 .1332 1.97 .2232 2.96 .1240 3.95 .0080 4.94 .0398 5.93 .0194 6.92 .0059
- 7.90 .0022 8.91 .0008 9.88 .0017 10.87 .0005 11.85 .0004 12.84 .0008 13.83 .0009 14.82 .0032
- 15.81 .0009 16.81 .0017 17.78 .0009 18.77 .0003 19.76 .0002 20.75 .0006 21.74 .0004 22.73 .0002))
-
-(define ssax-d5 '( .99 .1242 1.98 .0414 2.97 .0487 3.96 .0182 4.95 .0225 5.94 .0112 6.93 .0012
- 7.92 .0035 8.87 .0004 9.90 .0011 10.89 .0006 11.88 .0004 12.81 .0008 13.87 .0011 14.86 .0015
- 15.84 .0005 16.83 .0002 17.82 .0005 18.46 .0002 19.82 .0002 20.81 .0002 21.66 .0001))
-
-(define ssax-ds5 '( .99 .1419 1.98 .0180 2.98 .0683 3.96 .0172 4.95 .0329 5.94 .0093 6.93 .0017
- 7.91 .0014 8.91 .0022 9.90 .0018 10.88 .0004 11.89 .0011 12.88 .0009 13.87 .0010 14.83 .0007
- 15.85 .0004 16.85 .0002 17.85 .0003 18.85 .0003 20.81 .0001))
-
-(define ssax-e5 '( 1.00 .2435 1.99 .0422 2.99 .0422 3.98 .0137 4.97 .0155 5.97 .0127 6.96 .0024
- 7.96 .0014 8.95 .0017 9.95 .0011 10.94 .0006 11.94 .0009 12.93 .0022 13.92 .0048 14.92 .0004
- 15.91 .0006 16.91 .0003 17.90 .0002 18.89 .0002 19.89 .0002))
-
-(define ssax-f5 '( 1.00 .2095 2.00 .0502 3.01 .0783 4.01 .0216 5.01 .0293 6.01 .0080 7.01 .0043
- 8.02 .0036 9.02 .0019 10.02 .0002 11.02 .0013 12.02 .0010 13.02 .0007 14.03 .0010 15.03 .0003
- 16.03 .0013 17.04 .0009 18.04 .0005))
-
-(define ssax-fs5 '( .99 .1379 1.98 .0339 2.98 .0480 3.97 .0340 4.96 .0264 5.95 .0126 6.94 .0046
- 7.93 .0030 8.92 .0013 9.91 .0010 10.90 .0009 11.89 .0007 12.88 .0007 13.88 .0018 14.87 .0012
- 15.86 .0006 16.85 .0004 17.84 .0007))
-
-(define ssax-g5 '( .99 .0699 1.98 .0273 2.96 .0227 3.95 .0133 4.94 .0151 5.92 .0023 6.92 .0024
- 7.91 .0011 8.90 .0009 9.89 .0018 10.87 .0009 11.88 .0016 12.86 .0007 13.84 .0008 14.83 .0007
- 15.82 .0005 16.81 .0003))
-
-(define ssax-gs5 '( 1.00 .1830 1.99 .0897 2.99 .0456 3.99 .0296 4.99 .0125 5.98 .0059 6.98 .0105
- 7.98 .0027 8.97 .0044 9.97 .0096 10.97 .0011 11.97 .0027 12.97 .0006 13.97 .0024 14.96 .0014
- 15.95 .0002))
-
-(define ssax-a5 '( .99 .2010 1.98 .0677 2.97 .0195 3.97 .0363 4.96 .0191 5.95 .0092 6.94 .0047
- 7.93 .0021 7.96 .0004 8.91 .0004 9.92 .0039 10.90 .0023 11.91 .0005 12.88 .0008 12.91 .0002
- 13.86 .0002 14.87 .0007))
-
-(define ssax-as5 '( 1.00 .1011 1.99 .0696 2.99 .0359 3.98 .0008 4.99 .0111 5.98 .0027 6.98 .0005
- 7.98 .0038 8.98 .0032 9.98 .0037 10.97 .0024 11.97 .0012 12.97 .0009 13.97 .0004))
-
-(define ssax-b5 '( .98 .0933 1.95 .0632 2.93 .0226 4.89 .0036 5.86 .0133 6.84 .0018 7.82 .0036
- 8.79 .0037 9.77 .0111 10.75 .0011 11.72 .0009 12.70 .0013))
-
-(define ssax-c6 '( 1.01 .0218 1.98 .0033 3.00 .0037 3.99 .0010 4.03 .0009 4.77 .0002 4.95 .0002
- 6.01 .0001 7.00 .0002 8.02 .0004 9.03 .0004 10.03 .0003 12.03 .0001))
-
-(define ssax-cs6 '( .99 .1143 1.99 .0478 2.99 .0259 3.97 .0101 4.97 .0058 5.96 .0010 6.95 .0012
- 7.98 .0017 8.95 .0024 8.98 .0016 9.96 .0007 10.93 .0019 10.96 .0010 11.90 .0003 11.95 .0002))
-
-(define ssax-d6 '( 1.01 .0247 2.02 .0062 3.02 .0036 4.03 .0052 5.05 .0006 6.07 .0004 7.06 .0013
- 8.07 .0027 11.11 .0001))
-
-
-;;;
-;;;
-;;;
-;;;
-;;;
-(define tbf-e2 '( 1.01 .0028 2.00 .0192 3.04 .0188 4.02 .0134 5.02 .0319 6.05 .0335 7.04 .0136
- 8.06 .0074 9.07 .0527 10.06 .0217 11.05 .0025 12.09 .0068 13.08 .0278 14.10 .0125 15.09 .0152
- 16.13 .0101 17.13 .0088 18.11 .0094 19.14 .0084 20.20 .0008 21.13 .0031 22.16 .0097 23.14 .0053
- 24.17 .0030 25.20 .0013 26.17 .0055 27.20 .0049 28.19 .0040 29.21 .0010 30.21 .0030 31.20 .0032
- 32.24 .0031 33.21 .0006 34.23 .0015 35.25 .0020 36.23 .0012 37.25 .0010 38.29 .0007 39.26 .0017
- 40.29 .0014 41.27 .0015 42.29 .0005 43.32 .0012 44.30 .0014 45.32 .0010 46.32 .0005 47.31 .0003
- 48.34 .0009 49.32 .0005 50.34 .0005 51.35 .0001 52.35 .0005 53.37 .0006 54.37 .0006 55.38 .0001
- 56.38 .0002 57.39 .0006 58.41 .0005 59.42 .0004 60.42 .0001 61.43 .0004 62.41 .0004 63.42 .0003
- 64.45 .0002 65.46 .0001 66.45 .0003 67.48 .0003 68.46 .0001 69.50 .0001 70.49 .0004 71.48 .0002
- 72.47 .0001 74.52 .0002 75.51 .0002 76.51 .0002 79.55 .0002 80.56 .0002 81.55 .0001 83.58 .0002
- 84.57 .0001 85.59 .0002 87.60 .0002 88.59 .0001 89.61 .0002 92.62 .0001 93.64 .0001 96.67 .0001
- 98.69 .0001))
-
-(define tbf-f2 '( .99 .0062 2.00 .0189 3.01 .0059 4.03 .0167 5.01 .0454 6.01 .0190 7.03 .0261
- 8.04 .0495 9.04 .0195 10.01 .0059 11.02 .0030 12.05 .0247 13.04 .0097 14.05 .0122 15.04 .0076
- 16.03 .0044 17.05 .0063 18.06 .0045 19.06 .0011 20.05 .0028 21.07 .0056 22.07 .0019 22.55 .0004
- 23.17 .0001 24.07 .0026 25.08 .0016 26.10 .0017 27.11 .0006 28.09 .0011 29.10 .0014 30.10 .0011
- 31.13 .0007 32.12 .0006 33.11 .0009 34.10 .0004 35.15 .0002 36.15 .0004 37.13 .0006 38.11 .0004
- 39.11 .0002 40.15 .0003 41.13 .0004 42.13 .0003 43.17 .0002 44.20 .0002 45.16 .0002 46.18 .0003
- 48.16 .0001 49.20 .0002 50.20 .0002 51.21 .0001 54.20 .0001))
-
-(define tbf-fs2 '( 1.02 .0056 2.01 .0355 3.01 .0221 3.99 .0130 4.99 .0606 6.00 .0189 7.01 .0127
- 8.02 .0612 9.01 .0211 10.01 .0079 10.99 .0134 11.99 .0205 13.00 .0282 14.03 .0114 15.02 .0079
- 16.01 .0116 17.00 .0082 18.02 .0015 19.00 .0052 20.03 .0082 21.03 .0057 22.05 .0011 23.02 .0048
- 24.01 .0035 25.01 .0032 26.02 .0012 27.04 .0033 28.01 .0015 29.03 .0013 30.05 .0008 31.03 .0024
- 32.02 .0010 33.02 .0007 34.05 .0007 35.05 .0013 36.04 .0008 37.03 .0004 38.02 .0004 39.03 .0008
- 40.03 .0005 42.07 .0005 43.05 .0006 44.05 .0003 45.10 .0002 46.05 .0003 47.05 .0003 48.05 .0002
- 50.08 .0003 51.07 .0003 52.06 .0002 53.09 .0001 54.00 .0001 55.06 .0002 56.09 .0002 57.10 .0001
- 58.08 .0001 59.05 .0001 60.09 .0001 62.09 .0001 63.06 .0001 66.13 .0001))
-
-(define tbf-g2 '( .99 .0059 1.98 .0515 2.98 .0305 3.98 .0081 4.97 .0448 5.98 .0160 6.97 .0397
- 7.97 .0418 8.93 .0079 9.96 .0086 10.95 .0358 11.96 .0207 12.94 .0116 13.94 .0070 14.93 .0156
- 15.94 .0120 16.98 .0013 17.94 .0060 18.91 .0074 19.94 .0070 20.94 .0013 21.92 .0060 22.91 .0043
- 23.89 .0014 24.95 .0017 25.91 .0031 26.90 .0022 27.90 .0009 28.91 .0017 29.89 .0016 30.88 .0012
- 31.86 .0004 32.88 .0013 33.89 .0008 34.85 .0005 35.83 .0005 36.85 .0008 37.87 .0006 38.87 .0001
- 39.86 .0004 40.90 .0008 41.86 .0005 42.88 .0003 43.86 .0005 44.84 .0005 45.89 .0003 46.92 .0002
- 47.86 .0003 48.77 .0002 49.85 .0002 50.86 .0002 51.81 .0003 52.88 .0001 53.87 .0001 54.80 .0002
- 55.77 .0001 56.88 .0002 58.76 .0001 59.82 .0001 62.83 .0001 63.88 .0001 73.81 .0001))
-
-(define tbf-gs2 '( .99 .0058 1.98 .0327 2.99 .0282 3.99 .0353 4.98 .0348 5.96 .0451 6.97 .0549
- 7.97 .0183 8.96 .0096 9.94 .0221 10.94 .0110 11.93 .0102 12.92 .0074 13.92 .0109 14.91 .0080
- 15.15 .0013 15.91 .0003 16.90 .0034 17.88 .0030 18.88 .0036 19.14 .0004 20.05 .0003 20.86 .0029
- 21.87 .0014 22.84 .0008 23.85 .0021 24.83 .0011 25.81 .0007 26.80 .0003 27.81 .0010 28.82 .0003
- 29.84 .0003 30.77 .0006 31.75 .0002 32.78 .0005 33.79 .0003 34.77 .0003 35.78 .0003 37.75 .0002
- 38.72 .0002 41.75 .0001 42.73 .0001 45.69 .0001))
-
-(define tbf-a2 '( 1.00 .0085 1.99 .0291 2.99 .0151 4.00 .0554 5.00 .0164 6.02 .0087 7.00 .0365
- 8.06 .0023 9.02 .0098 9.98 .0165 10.97 .0176 11.97 .0107 12.98 .0081 13.97 .0077 14.97 .0012
- 15.99 .0038 16.98 .0028 17.97 .0017 18.97 .0024 19.98 .0014 20.95 .0017 21.92 .0009 23.01 .0009
- 23.98 .0006 24.94 .0004 25.95 .0013 26.95 .0003 27.99 .0002 28.97 .0006 29.96 .0002 30.90 .0003
- 31.89 .0003 32.83 .0002 33.02 .0001 33.78 .0001 34.94 .0001 35.94 .0002 38.91 .0002 39.88 .0001))
-
-(define tbf-as2 '( 1.00 .0251 2.05 .0009 3.02 .0385 4.03 .0997 5.03 .0337 6.04 .1061 7.04 .0539
- 8.05 .0357 9.06 .0635 10.06 .0233 11.05 .0153 12.07 .0218 13.07 .0235 14.08 .0092 15.08 .0135
- 16.09 .0104 17.09 .0055 18.10 .0130 19.11 .0059 20.12 .0030 21.12 .0060 22.12 .0029 23.12 .0032
- 24.13 .0022 25.14 .0016 26.14 .0007 27.15 .0032 28.15 .0014 29.16 .0012 30.15 .0015 31.18 .0011
- 32.19 .0008 33.18 .0014 34.19 .0007 35.19 .0003 36.18 .0009 37.16 .0004 39.21 .0007 40.22 .0006
- 41.23 .0001 42.20 .0004 43.24 .0007 45.25 .0007 46.26 .0004 47.32 .0001 48.26 .0004 49.26 .0003
- 51.29 .0003 52.28 .0002 54.30 .0003 55.32 .0002 57.31 .0002 58.32 .0001 60.31 .0002 61.30 .0001
- 63.35 .0001 64.34 .0001 66.37 .0001))
-
-(define tbf-b2 '( 1.02 .0294 2.03 .0276 3.03 .0170 4.05 .0409 5.06 .0434 6.06 .0552 7.06 .0128
- 8.08 .0076 9.07 .0216 10.08 .0169 11.07 .0035 12.09 .0094 13.10 .0046 14.12 .0021 15.12 .0059
- 16.13 .0023 17.15 .0039 18.16 .0035 19.17 .0015 20.18 .0020 21.19 .0023 22.19 .0005 23.22 .0022
- 24.24 .0010 25.27 .0006 26.26 .0008 27.27 .0010 28.28 .0003 29.28 .0006 30.27 .0005 31.32 .0003
- 32.30 .0004 33.29 .0004 35.37 .0004 36.34 .0002 37.38 .0002 38.38 .0003 39.48 .0002 41.43 .0003
- 42.40 .0001 44.50 .0001 45.47 .0001 47.46 .0001))
-
-(define tbf-c3 '( 1.01 .0167 2.00 .0116 3.00 .0033 3.99 .0432 5.01 .0116 6.00 .0573 7.00 .0128
- 8.00 .0582 9.02 .0354 10.01 .0203 11.00 .0226 12.00 .0167 13.03 .0055 14.02 .0174 15.01 .0088
- 16.01 .0083 17.03 .0066 18.03 .0022 19.01 .0058 20.01 .0049 21.03 .0016 22.03 .0053 23.03 .0028
- 24.01 .0013 25.03 .0028 26.03 .0015 27.00 .0003 28.02 .0026 28.39 .0002 29.70 .0002 30.03 .0014
- 31.03 .0010 32.04 .0007 33.03 .0010 34.03 .0007 35.04 .0004 36.03 .0009 37.03 .0004 38.05 .0006
- 39.04 .0008 40.03 .0003 41.04 .0004 42.04 .0005 43.06 .0003 44.02 .0004 45.03 .0002 46.08 .0001
- 47.05 .0004 48.03 .0002 49.06 .0001 50.05 .0003 51.06 .0002 52.07 .0002 53.04 .0002 54.05 .0001
- 55.05 .0002 56.05 .0001 58.05 .0002 59.06 .0001 61.05 .0002))
-
-(define tbf-cs3 '( 1.00 .0192 1.98 .0300 2.99 .0565 3.98 .0329 4.97 .0791 5.98 .0457 6.96 .0053
- 7.95 .0405 8.96 .0260 9.95 .0146 10.93 .0283 11.95 .0038 12.93 .0205 13.92 .0086 14.93 .0028
- 15.91 .0069 16.91 .0030 17.91 .0095 18.89 .0058 19.90 .0023 20.89 .0048 21.87 .0015 22.89 .0033
- 23.88 .0021 24.87 .0003 25.87 .0030 26.86 .0014 27.85 .0016 28.86 .0021 29.85 .0005 30.83 .0019
- 31.84 .0014 32.83 .0005 33.82 .0012 34.82 .0006 35.81 .0008 36.82 .0011 37.81 .0004 38.78 .0004
- 39.80 .0005 40.79 .0004 41.77 .0007 42.77 .0002 43.78 .0004 44.76 .0005 45.77 .0003 46.76 .0003
- 47.75 .0002 48.75 .0002 49.75 .0005 50.74 .0002 51.73 .0002 52.73 .0002 53.72 .0002 54.73 .0003
- 55.70 .0001 56.70 .0001 57.71 .0003 58.71 .0001 59.70 .0002 60.70 .0001 61.69 .0002 62.69 .0003
- 64.67 .0001 65.67 .0001 67.64 .0001 69.65 .0001 70.63 .0001 75.62 .0001))
-
-(define tbf-d3 '( 1.01 .0462 2.01 .0592 3.00 .1127 3.99 .0398 5.00 .1221 6.02 .0099 7.01 .0396
- 8.01 .0429 9.00 .0249 10.00 .0223 10.27 .0015 11.03 .0010 12.01 .0146 13.01 .0097 14.00 .0008
- 15.00 .0064 16.01 .0020 17.02 .0066 18.02 .0043 19.02 .0021 20.01 .0035 21.02 .0009 22.02 .0022
- 23.03 .0022 24.00 .0007 25.02 .0025 26.02 .0002 27.03 .0017 27.30 .0003 28.73 .0002 29.03 .0016
- 30.02 .0012 31.02 .0006 32.04 .0013 33.04 .0005 34.02 .0006 35.01 .0004 36.03 .0007 37.03 .0009
- 38.05 .0003 39.05 .0006 40.04 .0003 41.04 .0003 42.04 .0005 43.05 .0002 44.06 .0003 45.05 .0001
- 46.05 .0002 47.04 .0003 48.06 .0002 49.06 .0003 50.06 .0001 51.06 .0001 52.04 .0001 53.06 .0001
- 54.06 .0002 57.06 .0001 58.07 .0001 59.06 .0002 66.09 .0001))
-
-(define tbf-ds3 '( 1.00 .0462 2.01 .0546 3.03 .1220 4.04 .0672 5.06 .0575 6.07 .0310 7.08 .0402
- 8.09 .0228 9.09 .0345 10.10 .0204 11.11 .0134 12.12 .0171 13.13 .0056 14.15 .0087 15.16 .0035
- 16.17 .0068 17.18 .0027 18.18 .0061 19.20 .0018 20.20 .0037 21.22 .0030 22.24 .0013 23.24 .0028
- 23.58 .0004 24.91 .0002 25.26 .0031 26.26 .0008 27.27 .0022 28.28 .0021 29.29 .0013 30.31 .0017
- 31.31 .0006 32.34 .0015 33.34 .0008 34.35 .0012 35.36 .0012 36.36 .0008 37.37 .0012 38.38 .0006
- 39.40 .0008 40.39 .0002 41.43 .0004 42.44 .0003 43.45 .0004 44.45 .0004 45.45 .0004 46.46 .0006
- 47.46 .0002 48.48 .0004 49.47 .0002 50.52 .0003 51.52 .0002 52.53 .0003 53.53 .0003 54.54 .0002
- 55.55 .0003 57.58 .0002 58.58 .0001 59.60 .0002 60.60 .0002 61.62 .0002 62.63 .0002 63.62 .0001
- 64.64 .0002 66.67 .0001 68.68 .0001 69.70 .0001 71.70 .0001))
-
-(define tbf-e3 '( 1.00 .0427 2.02 .0329 3.03 .0739 4.03 .0442 5.05 .0547 6.06 .0547 7.06 .0357
- 8.07 .0307 9.09 .0344 10.10 .0088 11.10 .0255 12.12 .0049 13.13 .0161 14.13 .0032 15.14 .0087
- 16.16 .0028 17.15 .0054 18.17 .0018 19.18 .0048 20.20 .0025 21.19 .0033 22.21 .0032 23.22 .0009
- 24.22 .0017 25.25 .0004 26.24 .0011 26.54 .0002 27.27 .0002 28.26 .0012 28.54 .0002 29.26 .0001
- 30.29 .0009 31.29 .0003 32.30 .0007 33.32 .0005 34.32 .0007 35.32 .0005 36.35 .0004 37.36 .0004
- 38.38 .0002 39.37 .0004 41.39 .0004 42.42 .0001 43.40 .0002 45.43 .0002 47.45 .0002 48.45 .0001
- 49.46 .0001 50.48 .0002 51.49 .0001 52.49 .0001 54.52 .0001 56.54 .0001))
-
-(define tbf-f3 '( 1.01 .0430 2.02 .0658 3.02 .0533 4.02 .1351 5.04 .0653 6.03 .0900 7.05 .0410
- 8.05 .0344 9.07 .0169 10.07 .0220 11.08 .0159 12.08 .0180 13.08 .0045 14.09 .0098 15.08 .0023
- 16.10 .0022 17.12 .0040 18.12 .0030 19.13 .0031 20.14 .0014 21.14 .0019 22.15 .0012 23.16 .0015
- 24.16 .0007 25.16 .0010 26.17 .0009 27.19 .0009 28.19 .0004 29.20 .0009 30.19 .0002 31.21 .0007
- 32.23 .0003 33.23 .0005 35.24 .0004 36.33 .0001 37.25 .0003 38.26 .0002 39.27 .0003 41.29 .0002
- 42.29 .0001 43.30 .0002 45.31 .0001 46.33 .0001))
-
-(define tbf-fs3 '( 1.00 .0676 1.99 .0337 3.00 .0651 4.00 .0928 4.99 .0773 6.00 .0359 6.99 .0266
- 7.99 .0183 9.00 .0246 9.99 .0092 10.98 .0144 11.99 .0027 12.98 .0112 13.98 .0019 14.99 .0058
- 15.97 .0010 16.97 .0024 17.98 .0033 18.97 .0025 19.97 .0024 20.98 .0018 21.97 .0030 22.98 .0013
- 23.97 .0026 24.19 .0004 24.97 .0003 25.97 .0026 26.96 .0003 27.96 .0018 28.97 .0006 29.96 .0012
- 30.96 .0012 31.97 .0011 32.96 .0012 33.95 .0006 34.96 .0008 35.95 .0003 36.95 .0009 37.95 .0002
- 38.95 .0005 39.95 .0002 40.95 .0005 41.95 .0003 42.95 .0005 43.95 .0002 44.94 .0003 45.95 .0003
- 46.94 .0001 47.94 .0002 49.94 .0003 50.94 .0001 51.94 .0003 53.93 .0002 55.93 .0002 56.93 .0001
- 57.93 .0002 58.93 .0001 59.93 .0001 60.93 .0001 62.93 .0001 64.91 .0001))
-
-(define tbf-g3 '( 1.01 .1108 2.02 .0159 3.03 .0749 4.03 .0774 5.05 .0554 6.06 .0287 7.06 .0529
- 8.08 .0167 9.09 .0172 10.09 .0181 11.10 .0072 12.12 .0148 13.11 .0028 14.13 .0060 15.14 .0012
- 16.14 .0047 17.15 .0034 18.17 .0009 19.17 .0041 20.18 .0007 21.20 .0016 22.20 .0011 23.21 .0022
- 24.23 .0010 25.24 .0008 26.24 .0015 27.25 .0003 28.26 .0011 29.26 .0009 30.28 .0009 31.29 .0007
- 32.29 .0002 33.31 .0005 34.32 .0001 35.32 .0006 36.33 .0002 37.35 .0003 38.34 .0004 40.37 .0003
- 42.39 .0002 43.40 .0002 44.40 .0001 45.41 .0002 47.44 .0002 50.47 .0001 52.48 .0001 54.49 .0001))
-
-(define tbf-gs3 '( 1.01 .0962 2.01 .0925 3.01 .0770 4.03 .0479 5.03 .1190 6.03 .0237 7.03 .0168
- 8.05 .0283 9.05 .0100 10.05 .0292 11.06 .0097 12.07 .0103 13.07 .0121 14.07 .0042 15.08 .0012
- 16.09 .0051 17.09 .0023 18.09 .0058 19.11 .0009 20.11 .0029 21.11 .0028 22.12 .0011 23.13 .0028
- 24.12 .0013 25.13 .0016 26.14 .0014 27.14 .0009 28.15 .0016 29.16 .0007 30.16 .0007 31.16 .0010
- 32.17 .0004 33.18 .0006 34.18 .0005 35.18 .0003 36.19 .0006 37.20 .0003 38.20 .0003 39.21 .0004
- 40.22 .0002 41.22 .0004 42.23 .0001 43.23 .0002 44.24 .0002 46.25 .0003 47.25 .0001 48.26 .0002
- 49.26 .0001 51.28 .0001 54.29 .0001))
-
-(define tbf-a3 '( .99 .0880 1.99 .1784 2.99 .0966 3.99 .0789 4.99 .0440 5.99 .0574 6.99 .0067
- 7.99 .0384 8.98 .0270 9.98 .0089 10.97 .0152 11.97 .0039 12.97 .0092 13.97 .0081 14.97 .0020
- 15.97 .0030 16.96 .0051 17.96 .0014 18.96 .0031 19.96 .0026 20.95 .0004 21.95 .0028 22.95 .0006
- 23.94 .0012 24.94 .0021 25.94 .0009 26.94 .0010 27.94 .0010 28.94 .0006 29.94 .0008 30.93 .0009
- 31.93 .0001 32.92 .0007 33.92 .0005 34.91 .0002 35.92 .0005 36.91 .0003 37.92 .0002 38.92 .0004
- 40.91 .0002 41.90 .0002 43.89 .0002 44.89 .0002 46.89 .0001 49.89 .0001 52.88 .0001))
-
-(define tbf-as3 '( 1.00 .0084 2.02 .2204 3.02 .1914 4.03 .0999 5.03 .0302 6.04 .0574 7.04 .0432
- 8.05 .0168 9.05 .0414 10.06 .0213 11.06 .0024 12.07 .0063 13.08 .0058 14.08 .0014 15.09 .0031
- 16.09 .0067 17.10 .0026 18.10 .0026 19.11 .0039 20.11 .0016 21.12 .0015 22.12 .0032 23.13 .0017
- 24.13 .0010 25.14 .0020 26.14 .0016 27.15 .0002 28.16 .0013 29.16 .0009 31.17 .0009 32.18 .0008
- 33.18 .0004 34.19 .0005 35.19 .0008 36.20 .0002 37.20 .0004 38.21 .0005 39.21 .0002 40.22 .0002
- 41.22 .0003 42.23 .0002 43.23 .0001 44.24 .0002 45.25 .0001 47.26 .0002 48.26 .0001 50.28 .0001
- 51.28 .0001))
-
-(define tbf-b3 '( 1.00 .0475 2.00 .1146 3.01 .1513 4.01 .0759 5.00 .0441 6.01 .0348 7.01 .0462
- 8.01 .0291 9.02 .0056 10.02 .0281 11.01 .0178 12.02 .0016 13.02 .0054 14.02 .0082 15.03 .0051
- 16.02 .0014 17.02 .0053 18.03 .0050 19.03 .0017 20.03 .0024 21.04 .0037 22.03 .0025 23.03 .0008
- 24.04 .0028 25.04 .0023 26.04 .0007 27.04 .0007 28.04 .0018 29.04 .0017 30.05 .0003 31.04 .0011
- 32.04 .0013 33.05 .0004 34.05 .0005 35.05 .0009 36.06 .0007 37.05 .0002 38.06 .0004 39.06 .0006
- 40.06 .0004 41.07 .0003 42.06 .0005 43.06 .0004 44.07 .0001 45.07 .0003 46.07 .0003 47.08 .0001
- 48.07 .0001 49.07 .0003 50.08 .0002 52.08 .0001 53.08 .0001))
-
-(define tbf-c4 '( 1.01 .0092 2.01 .0918 3.01 .1218 4.03 .1524 5.03 .0561 6.03 .0196 7.05 .0312
- 8.05 .0481 9.05 .0292 10.07 .0048 11.07 .0035 12.07 .0096 13.08 .0079 14.09 .0040 15.09 .0017
- 16.09 .0054 17.11 .0080 18.11 .0039 19.11 .0010 20.13 .0034 21.13 .0028 22.13 .0027 23.14 .0004
- 24.15 .0015 25.15 .0024 26.16 .0021 27.17 .0006 28.17 .0008 29.17 .0013 30.19 .0015 31.19 .0005
- 32.19 .0002 33.21 .0009 34.21 .0010 35.21 .0006 36.23 .0003 37.23 .0005 38.23 .0009 39.24 .0007
- 40.25 .0002 41.25 .0004 42.26 .0006 43.27 .0004 44.27 .0002 45.27 .0003 46.29 .0004 47.29 .0003
- 48.29 .0001))
-
-(define tbf-cs4 '( 1.00 .0881 2.00 .1170 3.00 .0852 4.00 .0643 5.00 .0778 6.00 .0489 6.99 .0269
- 8.00 .0107 8.99 .0292 10.00 .0159 10.99 .0082 12.00 .0066 12.99 .0009 14.00 .0050 14.99 .0064
- 15.99 .0059 17.00 .0044 17.99 .0024 19.00 .0042 19.99 .0040 21.00 .0027 21.99 .0023 22.99 .0018
- 23.99 .0024 24.99 .0025 25.99 .0019 26.99 .0007 27.99 .0004 28.99 .0012 29.99 .0014 30.99 .0012
- 31.99 .0004 32.99 .0002 33.99 .0007 34.98 .0009 35.99 .0008 36.98 .0005 37.99 .0002 38.98 .0005
- 39.99 .0007 40.98 .0007 41.98 .0004 42.98 .0001 43.98 .0003 44.99 .0004 45.98 .0003))
-
-(define tbf-d4 '( 1.01 .1228 2.02 .1247 3.02 .1142 4.03 .0474 5.04 .0335 6.04 .0332 7.05 .0302
- 8.06 .0222 9.07 .0090 10.08 .0030 11.09 .0027 12.09 .0054 13.10 .0059 14.10 .0040 15.11 .0038
- 16.12 .0029 17.13 .0011 18.14 .0020 19.15 .0021 20.15 .0023 21.16 .0016 22.17 .0012 23.17 .0008
- 24.18 .0003 25.19 .0006 26.20 .0008 27.21 .0008 28.22 .0008 29.22 .0004 30.23 .0002 31.23 .0002
- 32.24 .0003 33.26 .0004 34.26 .0004 35.27 .0004 36.28 .0002 39.29 .0002 40.30 .0002 41.32 .0001))
-
-(define tbf-ds4 '( 1.01 .1133 2.01 .1562 3.02 .1429 4.02 .0366 5.02 .0219 6.03 .0212 7.03 .0142
- 8.04 .0216 9.04 .0101 10.04 .0063 11.05 .0076 12.05 .0081 13.06 .0050 14.06 .0030 15.07 .0010
- 16.07 .0011 17.07 .0019 18.08 .0022 19.08 .0029 20.09 .0028 21.09 .0021 22.09 .0016 23.10 .0016
- 24.10 .0010 25.11 .0005 26.11 .0003 27.11 .0002 28.12 .0006 29.12 .0004 30.13 .0005 31.13 .0004
- 32.13 .0006 33.14 .0003 34.14 .0003 35.15 .0002 37.15 .0002 38.15 .0001 39.16 .0002 40.16 .0002
- 41.17 .0002))
-
-(define tbf-e4 '( .99 .0906 1.99 .1338 2.99 .1235 3.98 .0833 4.98 .0601 5.98 .0264 6.98 .0126
- 7.97 .0051 8.97 .0026 9.97 .0014 10.96 .0018 11.96 .0025 12.96 .0031 13.96 .0021 14.95 .0034
- 15.95 .0035 16.95 .0037 17.94 .0031 18.94 .0021 19.93 .0021 20.93 .0016 21.92 .0010 22.92 .0012
- 23.92 .0011 24.91 .0007 25.91 .0004 26.91 .0002 28.91 .0001 30.89 .0001 31.90 .0002 32.90 .0002
- 33.89 .0002 34.89 .0002 35.88 .0002 36.88 .0002 37.88 .0002 38.87 .0001))
-
-(define tbf-f4 '( 1.01 .1228 2.01 .3008 3.01 .1922 4.01 .0927 5.01 .0581 6.02 .0447 7.02 .0207
- 8.03 .0106 9.02 .0057 10.02 .0018 11.03 .0040 12.03 .0041 13.04 .0040 14.04 .0039 15.04 .0042
- 16.04 .0034 17.05 .0035 18.05 .0038 19.06 .0033 20.06 .0029 21.06 .0024 22.06 .0020 23.07 .0018
- 24.07 .0015 25.07 .0012 26.07 .0009 27.07 .0006 28.08 .0005 29.08 .0003 30.09 .0003 31.10 .0003
- 32.10 .0004 33.11 .0004 34.11 .0004 35.10 .0004 36.10 .0004 37.11 .0003 38.11 .0002))
-
-(define tbf-fs4 '( 1.01 .0765 2.01 .2561 3.02 .0803 4.03 .0653 5.03 .0230 6.04 .0093 7.05 .0035
- 8.05 .0042 9.06 .0040 10.07 .0052 11.07 .0056 12.08 .0049 13.09 .0039 14.09 .0035 15.10 .0031
- 16.10 .0021 17.11 .0012 18.12 .0010 19.12 .0005 20.13 .0003 21.14 .0001 22.14 .0001 23.15 .0003
- 24.16 .0002 25.16 .0003 26.17 .0003 27.18 .0003 28.18 .0003 29.19 .0003 30.20 .0002 31.20 .0001))
-
-(define tbf-g4 '( 1.01 .0092 2.02 .2167 3.02 .0668 4.02 .0254 5.03 .0210 6.04 .0282 7.04 .0151
- 8.05 .0130 9.05 .0054 10.06 .0031 11.07 .0014 12.08 .0020 13.08 .0020 14.09 .0020 15.09 .0021
- 16.10 .0015 17.10 .0007 18.11 .0003 19.13 .0002 20.13 .0004 21.13 .0005 22.14 .0004 23.14 .0003
- 24.15 .0003 25.15 .0001 29.18 .0001 30.19 .0001))
-
-(define tbf-gs4 '( 1.00 .1758 2.01 .1249 3.01 .0253 4.02 .0471 5.02 .0478 6.03 .0217 7.03 .0025
- 8.04 .0044 9.05 .0066 10.05 .0060 11.05 .0030 12.06 .0021 13.09 .0005 14.07 .0008 15.07 .0014
- 16.08 .0010 17.08 .0005 18.10 .0002 19.09 .0003 20.10 .0003 21.10 .0003 22.10 .0001 24.13 .0001
- 25.13 .0001 26.13 .0001))
-
-(define tbf-a4 '( 1.00 .3944 2.01 .1441 3.00 .0979 4.01 .0595 5.01 .0218 6.01 .0057 7.01 .0131
- 8.01 .0053 9.01 .0018 10.02 .0029 11.01 .0042 12.02 .0032 13.01 .0001 14.02 .0014 15.02 .0017
- 16.02 .0006 17.03 .0003 18.02 .0006 19.03 .0009 20.03 .0003 21.04 .0002 22.03 .0004 23.03 .0004
- 25.04 .0002 26.04 .0003 27.04 .0001))
-
-(define tbf-as4 '( 1.01 .3895 2.03 .1550 3.03 .0985 4.05 .0153 5.06 .0280 6.07 .0103 7.08 .0028
- 8.10 .0069 9.10 .0023 10.12 .0025 11.13 .0029 12.14 .0011 13.15 .0011 14.16 .0009 15.17 .0002
- 16.19 .0007 17.20 .0004 18.22 .0002 19.22 .0003 20.23 .0001 22.26 .0001))
-
-(define tbf-b4 '( 1.00 .2165 2.01 .1597 3.00 .0717 4.01 .0353 5.01 .0332 6.01 .0024 7.01 .0088
- 8.02 .0009 9.02 .0039 10.02 .0016 11.02 .0015 12.02 .0014 13.03 .0003 14.03 .0007 16.03 .0004
- 17.04 .0002 18.03 .0002 19.04 .0001))
-
-(define tbf-c5 '( 1.01 .1699 2.01 .2670 3.03 .0349 4.03 .0454 5.05 .0024 6.05 .0069 7.06 .0021
- 8.07 .0015 9.08 .0011 10.09 .0007 11.09 .0007 12.10 .0001 13.11 .0004 15.13 .0002))
-
-(define tbf-cs5 '( 1.00 .2017 2.00 .0920 3.00 .0598 3.99 .0086 4.99 .0120 5.99 .0063 6.99 .0034
- 7.99 .0029 8.99 .0008 9.99 .0014 10.98 .0008 11.97 .0007 12.98 .0006 13.96 .0001 14.97 .0003
- 15.97 .0001))
-
-;;;
-;;;
-;;;
-;;;
-;;;
-(define tbp-e2 '( 1.00 .0179 2.00 .0770 2.99 .0532 3.99 .0183 4.97 .0494 5.98 .0137 6.95 .0121
- 7.97 .0153 8.94 .0012 9.96 .0040 10.97 .0030 11.93 .0021 12.93 .0034 13.94 .0007 14.91 .0004
- 16.01 .0002 16.93 .0003 17.92 .0008 18.94 .0004 19.96 .0002 21.00 .0001 22.95 .0001 25.89 .0001))
-
-(define tbp-f2 '( .99 .0137 2.01 .0473 3.03 .0362 4.01 .0117 5.02 .0565 6.04 .0247 7.06 .0348
- 8.04 .0251 9.05 .0143 10.07 .0146 11.09 .0020 12.07 .0048 13.09 .0013 14.12 .0012 15.12 .0009
- 16.12 .0004 17.10 .0010 18.11 .0003 19.13 .0004 20.13 .0001 22.14 .0001 24.17 .0001))
-
-(define tbp-fs2 '( 1.02 .0110 2.02 .0470 3.02 .0038 4.02 .0343 5.01 .0442 6.02 .0198 7.01 .0600
- 8.02 .0144 9.05 .0468 10.05 .0112 11.05 .0137 12.05 .0078 13.05 .0041 14.05 .0040 15.05 .0012
- 16.05 .0018 17.05 .0007 18.08 .0011 19.08 .0003 20.09 .0005 21.08 .0004 22.08 .0002 23.07 .0003
- 25.07 .0001))
-
-(define tbp-g2 '( 1.01 .0148 2.00 .0544 3.02 .0144 4.01 .0848 5.03 .0334 6.02 .0703 7.01 .0546
- 8.03 .0242 9.02 .0235 10.04 .0054 11.02 .0079 12.04 .0009 13.03 .0032 14.02 .0011 15.04 .0013
- 16.02 .0005 17.06 .0005 18.01 .0001 19.01 .0002 20.07 .0002 21.08 .0001))
-
-(define tbp-gs2 '( .99 .0357 2.00 .0505 3.00 .0158 3.99 .0999 4.99 .0473 6.00 .0633 7.00 .0187
- 7.98 .0536 8.99 .0153 9.99 .0238 10.98 .0049 11.98 .0045 12.99 .0018 13.98 .0031 14.97 .0011
- 15.97 .0009 16.98 .0005 17.97 .0007 18.97 .0006 19.95 .0003 20.96 .0001))
-
-(define tbp-a2 '( 1.00 .0295 1.99 .1044 2.98 .0380 3.96 .1223 4.95 .0652 5.93 .0906 6.93 .0212
- 7.91 .0492 8.91 .0034 9.88 .0180 10.87 .0036 11.86 .0050 12.85 .0005 13.85 .0016 14.84 .0009
- 15.81 .0014 16.80 .0002 17.77 .0003 20.73 .0001 21.73 .0002 22.73 .0002 24.70 .0001))
-
-(define tbp-as2 '( 1.00 .0228 2.01 .0987 3.02 .0160 4.03 .0517 5.03 .0818 6.04 .0522 7.06 .0447
- 8.06 .0171 9.07 .0228 10.06 .0032 11.08 .0065 12.06 .0008 13.09 .0023 14.11 .0008 15.09 .0004
- 16.11 .0004 17.10 .0003 18.13 .0002 20.07 .0001))
-
-(define tbp-b2 '( 1.01 .0076 1.99 .0810 2.98 .0345 3.98 .0341 4.99 .0653 5.99 .0085 6.96 .0538
- 7.97 .0030 8.97 .0204 9.96 .0059 10.95 .0026 11.96 .0028 12.96 .0006 13.94 .0014 14.92 .0002
- 15.94 .0007 16.95 .0002))
-
-(define tbp-c3 '( 1.02 .0300 2.02 .0703 3.03 .1222 4.04 .0495 5.04 .0810 6.04 .0372 7.05 .0371
- 8.06 .0353 9.08 .0026 10.09 .0078 11.10 .0065 12.11 .0027 13.11 .0030 14.12 .0006 15.12 .0013
- 16.13 .0006 17.14 .0002 18.16 .0002 19.18 .0001 20.19 .0001 21.19 .0001))
-
-(define tbp-cs3 '( .99 .0466 1.97 .0094 2.97 .0953 3.95 .0427 4.96 .0520 5.94 .0187 6.94 .0127
- 7.92 .0075 8.90 .0015 9.90 .0017 10.88 .0009 11.89 .0002 12.85 .0002))
-
-(define tbp-d3 '( 1.01 .0634 2.02 .0187 3.02 .0987 4.02 .0742 5.02 .0182 6.03 .0331 7.03 .0132
- 8.03 .0025 9.04 .0026 10.06 .0016 11.07 .0002 12.08 .0001))
-
-(define tbp-ds3 '( 1.01 .1106 2.01 .0100 3.00 .0866 4.00 .0859 5.00 .0217 6.00 .0251 6.99 .0134
- 7.99 .0022 8.99 .0026 9.99 .0021 11.00 .0005 14.99 .0001 16.99 .0001))
-
-(define tbp-e3 '( 1.00 .1452 1.99 .0464 2.98 .0553 3.97 .1114 4.96 .0181 5.95 .0077 6.94 .0033
- 7.93 .0043 8.92 .0023 9.92 .0003 10.90 .0006 11.89 .0003 14.88 .0001 15.87 .0002 19.83 .0001))
-
-(define tbp-f3 '( .99 .0923 2.00 .0191 3.00 .0745 3.99 .1014 5.00 .0547 6.00 .0129 6.99 .0032
- 8.00 .0023 9.00 .0018 9.98 .0007 10.38 .0001 12.98 .0001))
-
-(define tbp-fs3 '( 1.01 .0781 2.00 .0346 2.99 .0441 4.01 .0196 5.00 .0310 5.99 .0213 7.00 .0062
- 7.99 .0021 9.00 .0003 9.99 .0002))
-
-(define tbp-g3 '( 1.01 .0733 2.03 .0883 3.03 .0772 4.05 .0148 5.06 .0055 6.06 .0033 7.09 .0026
- 8.09 .0015 9.11 .0003 10.12 .0002))
-
-(define tbp-gs3 '( 1.02 .0885 2.03 .1115 3.05 .0480 4.06 .0466 5.07 .0106 6.09 .0018 7.10 .0009))
-
-(define tbp-a3 '( 1.01 .1416 2.02 .1418 3.02 .0683 4.03 .0464 5.04 .0178 6.04 .0037 7.06 .0018
- 8.07 .0006 9.05 .0004))
-
-(define tbp-as3 '( 1.01 .1361 2.01 .0839 3.00 .0761 4.00 .0211 5.00 .0045 6.00 .0018 7.00 .0004))
-
-(define tbp-b3 '( 1.01 .0960 2.01 .0594 3.01 .0315 4.01 .0078 5.01 .0021 6.01 .0009 7.02 .0005
- 8.03 .0003))
-
-(define tbp-c4 '( 1.00 .0855 2.00 .1172 3.00 .0276 4.00 .0135 5.00 .0053 6.00 .0021 6.99 .0003))
-
-(define tbp-cs4 '( 1.01 .0033 2.00 .0982 2.99 .0491 3.99 .0185 4.99 .0043 5.98 .0004 6.99 .0001))
-
-(define tbp-d4 '( 1.01 .0485 2.01 .1552 3.01 .0547 4.01 .0136 5.03 .0026 6.04 .0010 7.05 .0001))
-
-(define tbp-ds4 '( 1.01 .0030 2.01 .1892 3.01 .0563 4.01 .0025 5.02 .0034 5.97 .0001 7.03 .0003))
-
-(define tbp-e4 '( 1.01 .0508 2.02 .0934 3.02 .0147 4.03 .0111 5.05 .0014 6.06 .0014 8.08 .0001))
-
-(define tbp-f4 '( 1.00 .0260 2.02 .2047 3.02 .0550 4.03 .0165 5.04 .0051 6.04 .0005 7.05 .0002))
-
-(define tbp-fs4 '( 1.02 .0971 2.03 .0635 3.04 .0254 4.05 .0023 5.07 .0002 6.08 .0003 7.09 .0001))
-
-(define tbp-g4 '( 1.02 .3176 2.03 .0734 3.04 .0332 4.05 .0152 5.06 .0048 6.08 .0007))
-
-(define tbp-gs4 '( 1.01 .3321 2.01 .1320 3.01 .0072 4.02 .0028 5.03 .0009 6.04 .0002 7.04 .0002))
-
-(define tbp-a4 '( 1.00 .5149 2.00 .2025 3.00 .0392 3.99 .0117 4.99 .0035 5.99 .0008 6.99 .0002
- 7.98 .0001))
-
-(define tbp-as4 '( 1.01 .3188 2.01 .2130 3.02 .0427 4.03 .0024 5.05 .0004 6.05 .0007 7.06 .0002
- 8.06 .0002))
-
-(define tbp-b4 '( 1.00 .1685 1.99 .0732 2.99 .0056 3.99 .0042 4.99 .0009 5.99 .0005))
-
-(define tbp-c5 '( 1.01 .3386 2.02 .0634 3.02 .0212 4.03 .0019 5.04 .0004))
-
-(define tbp-cs5 '( 1.00 .2958 2.00 .0843 3.01 .0058 4.01 .0027 5.01 .0003))
-
-(define tbp-d5 '( 1.00 .4237 2.01 .0453 3.01 .0045 4.02 .0007 5.02 .0004))
-
-;;;
-;;;
-;;;
-;;;
-;;; trumpet
-(define trp-fs3 '( 1.01 .0533 2.03 .0559 3.05 .0505 4.06 .0542 5.08 .0382 6.10 .0570 7.12 .0321
- 8.14 .0393 9.15 .0277 10.17 .0157 11.19 .0165 12.20 .0152 13.22 .0081 14.23 .0089 15.24 .0035
- 16.26 .0045 17.28 .0052 18.29 .0020 19.31 .0021 20.33 .0017 21.35 .0014 22.37 .0010 23.38 .0009
- 24.40 .0004 25.42 .0005 26.44 .0004 27.45 .0004 28.46 .0004 29.48 .0002 30.49 .0002 31.51 .0002
- 32.53 .0001 33.55 .0001))
-
-(define trp-g3 '( .99 .0459 1.99 .0931 3.00 .0517 4.00 .0496 5.00 .0576 6.00 .0452 7.00 .0263
- 8.00 .0125 9.01 .0131 10.01 .0136 11.00 .0066 12.00 .0081 13.00 .0032 14.00 .0039 14.99 .0026
- 16.00 .0017 16.99 .0017 17.99 .0009 19.01 .0013 20.01 .0008 21.01 .0006 22.00 .0006 23.00 .0003
- 24.01 .0004 25.01 .0003 26.01 .0002 27.02 .0002 28.02 .0001 29.02 .0001 31.04 .0001))
-
-(define trp-gs3 '( .99 .0455 1.99 .0969 2.97 .0487 3.97 .0296 4.97 .0186 5.95 .0219 6.95 .0075
- 7.94 .0176 8.93 .0202 9.93 .0175 10.91 .0156 11.91 .0097 12.91 .0066 13.89 .0065 14.89 .0051
- 15.88 .0037 16.86 .0015 17.87 .0016 18.85 .0010 19.85 .0006 20.84 .0006 21.84 .0006 22.84 .0005
- 23.82 .0003 24.82 .0003 25.80 .0002 26.79 .0002 27.79 .0001 28.79 .0001))
-
-(define trp-a3 '( .99 .0420 1.99 .0954 2.99 .0579 3.99 .0722 4.98 .0813 5.98 .0399 6.98 .0379
- 7.98 .0181 8.98 .0188 9.98 .0147 10.97 .0100 11.97 .0091 12.96 .0048 13.96 .0091 14.96 .0048
- 15.96 .0016 16.96 .0027 17.97 .0020 18.96 .0014 19.96 .0007 20.95 .0007 21.95 .0006 22.94 .0003
- 23.95 .0005 24.95 .0002 25.95 .0002 26.95 .0002 27.96 .0002 28.95 .0002 29.94 .0001))
-
-(define trp-as3 '( 1.01 .0487 2.01 .0236 3.01 .0599 4.01 .0397 5.01 .0525 6.01 .0426 7.00 .0144
- 8.01 .0134 9.01 .0274 10.01 .0087 11.01 .0041 12.00 .0052 13.01 .0080 14.01 .0028 15.02 .0022
- 16.01 .0014 17.04 .0005 18.04 .0003 19.03 .0005 20.02 .0003 21.02 .0003 22.02 .0003 23.03 .0002
- 24.03 .0002 25.02 .0001))
-
-(define trp-b3 '( 1.00 .0534 2.00 .0362 3.00 .0698 4.00 .0793 4.99 .0301 6.00 .0216 7.00 .0130
- 8.00 .0151 9.00 .0172 10.00 .0062 11.00 .0041 11.99 .0022 13.00 .0017 14.00 .0012 14.99 .0013
- 15.95 .0002 16.99 .0001 18.00 .0003 19.00 .0003 20.00 .0003 21.01 .0001))
-
-(define trp-c4 '( 1.01 .0410 2.03 .0543 3.03 .0487 4.04 .0354 5.05 .0408 6.06 .0221 7.08 .0099
- 8.09 .0248 9.09 .0107 10.11 .0037 11.11 .0087 12.13 .0035 13.14 .0012 14.16 .0013 15.17 .0002
- 16.18 .0002 17.19 .0003 18.20 .0002 19.21 .0002 20.22 .0002 21.23 .0001 22.24 .0001))
-
-(define trp-cs4 '( 1.01 .0199 2.03 .0437 3.03 .0142 4.04 .0534 5.04 .0310 6.06 .0194 7.06 .0124
- 8.06 .0071 9.07 .0061 10.06 .0037 11.09 .0022 12.12 .0007 13.11 .0005 14.12 .0003 15.10 .0002
- 16.12 .0002 17.13 .0001 18.13 .0001))
-
-(define trp-d4 '( 1.01 .0320 2.02 .0510 3.04 .0747 4.05 .0619 5.06 .0404 6.07 .0195 7.08 .0221
- 8.09 .0112 9.11 .0073 10.13 .0031 11.13 .0026 12.15 .0017 13.16 .0013 14.17 .0009 15.18 .0007
- 16.18 .0004 17.19 .0003 18.22 .0002 19.23 .0002 20.23 .0002 21.25 .0001))
-
-(define trp-ds4 '( 1.00 .0471 2.01 .0466 3.02 .0304 4.02 .0166 5.02 .0187 6.02 .0086 7.03 .0064
- 8.03 .0067 9.03 .0033 10.02 .0016 11.05 .0013 12.06 .0008 13.06 .0005 14.05 .0002 15.04 .0002
- 16.05 .0002 17.05 .0001))
-
-(define trp-e4 '( 1.01 .0365 2.01 .0352 3.02 .0462 4.02 .0230 5.02 .0092 6.02 .0078 7.02 .0059
- 8.04 .0034 9.04 .0011 10.05 .0010 11.07 .0003 12.07 .0003 13.06 .0002 14.06 .0001 15.07 .0001))
-
-(define trp-f4 '( 1.00 .0412 2.00 .0621 3.00 .0180 3.99 .0631 4.99 .0245 5.99 .0369 6.99 .0093
- 7.99 .0126 8.99 .0027 9.99 .0035 10.99 .0021 11.99 .0016 12.99 .0010 13.98 .0009 14.98 .0006
- 15.98 .0004 16.98 .0002))
-
-(define trp-fs4 '( .99 .0581 1.98 .0494 2.98 .0614 3.97 .0316 4.96 .0151 5.96 .0095 6.95 .0022
- 7.93 .0022 8.93 .0013 9.94 .0008 10.93 .0003 11.92 .0002 12.92 .0001 13.93 .0001))
-
-(define trp-g4 '( 1.00 .0979 1.99 .0344 2.99 .0374 3.99 .0179 4.98 .0148 5.98 .0059 6.98 .0029
- 7.95 .0005 8.97 .0004 9.97 .0002 10.96 .0002))
-
-(define trp-gs4 '( 1.00 .0670 2.00 .0138 3.00 .0100 4.01 .0076 4.99 .0070 5.99 .0037 6.97 .0023
- 7.97 .0007 8.97 .0002 9.98 .0001 10.97 .0002))
-
-(define trp-a4 '( 1.00 .0403 2.01 .0211 3.00 .0107 4.00 .0052 4.99 .0022 6.00 .0013 7.00 .0006
- 8.01 .0002 9.02 .0001 10.03 .0001))
-
-(define trp-as4 '( 1.00 .0128 2.01 .0154 3.00 .0269 3.99 .0098 4.99 .0021 5.98 .0016 6.99 .0004
- 8.00 .0003 9.02 .0002))
-
-(define trp-b4 '( 1.01 .0287 2.01 .0583 3.01 .0386 4.00 .0098 5.01 .0068 6.02 .0012 7.02 .0012
- 8.03 .0003 9.02 .0003 10.01 .0001))
-
-(define trp-c5 '( 1.01 .0190 2.01 .0057 3.01 .0039 4.01 .0051 5.03 .0005 6.02 .0002 7.03 .0001))
-
-(define trp-cs5 '( 1.01 .0087 2.01 .0050 3.01 .0011 4.01 .0002))
-
-(define trp-d5 '( 1.01 .0145 2.01 .0098 3.01 .0013 4.01 .0003))
-
-(define trp-ds5 '( 1.00 .0231 2.00 .0053 2.98 .0077 3.97 .0021 4.96 .0003 6.98 .0001))
-
-(define trp-e5 '( 1.01 .0520 2.02 .0187 3.00 .0009 4.04 .0011 5.02 .0001))
-
-(define trp-f5 '( 1.02 .0332 2.02 .0074 3.03 .0031))
-
-(define trp-fs5 '( 1.01 .1718 2.02 .1098 3.02 .0288 4.02 .0047 5.04 .0026 6.04 .0008 7.06 .0004
- 8.06 .0002))
-
-(define trp-g5 '( 1.02 .0825 2.03 .0364 3.04 .0160 4.06 .0045 5.07 .0011 6.09 .0005 7.10 .0002))
-
-(define trp-gs5 '( 1.02 .0114 2.02 .0346 3.02 .0045 4.04 .0013 5.06 .0002))
-
-(define trp-a5 '( 1.02 .0821 2.03 .0089 3.04 .0023 4.06 .0003 5.05 .0001))
-
-(define trp-as5 '( 1.01 .1554 2.01 .0287 3.02 .0084 4.02 .0035 5.03 .0007 6.04 .0002 7.04 .0001))
-
-(define trp-b5 '( 1.01 .0559 2.01 .0017 3.01 .0013 4.02 .0001))
-
-(define trp-c6 '( 1.01 .0291 2.00 .0150 3.01 .0032 4.02 .0004 5.02 .0002))
-
-
-;;;
-;;;
-;;;
-;;;
-;;;
-(define trpf-fs3 '( 1.00 .0292 1.99 .0424 3.00 .0242 4.00 .0413 4.99 .0315 6.00 .0454 7.00 .0143
- 7.98 .0108 8.99 .0077 9.99 .0084 10.99 .0071 11.98 .0078 12.97 .0085 13.98 .0032 14.97 .0035
- 15.97 .0052 16.96 .0021 17.96 .0033 18.96 .0024 19.97 .0016 20.95 .0015 21.95 .0011 22.95 .0006
- 23.95 .0007 24.94 .0006 25.94 .0004 26.94 .0003 27.93 .0004 28.93 .0003 29.93 .0002 30.92 .0003
- 31.92 .0001 32.93 .0001 33.91 .0002))
-
-(define trpf-g3 '( .99 .0286 1.97 .0669 2.95 .0456 3.95 .0345 4.94 .0617 5.91 .0341 6.90 .0225
- 7.89 .0264 8.88 .0155 9.86 .0160 10.84 .0150 11.83 .0085 12.82 .0112 13.80 .0054 14.78 .0042
- 15.77 .0056 16.76 .0023 17.73 .0027 18.71 .0010 19.73 .0014 20.69 .0014 21.68 .0007 22.67 .0007
- 23.64 .0007 24.63 .0004 25.62 .0005 26.59 .0003 27.62 .0002 28.56 .0003 29.55 .0001 30.53 .0002
- 31.51 .0002 32.50 .0001 33.48 .0002 35.47 .0001))
-
-(define trpf-gs3 '( .99 .0306 1.99 .0608 2.97 .0495 3.97 .0557 4.97 .0228 5.95 .0337 6.95 .0177
- 7.94 .0112 8.92 .0146 9.93 .0022 10.91 .0069 11.89 .0053 12.89 .0047 13.88 .0031 14.87 .0063
- 15.87 .0042 16.86 .0033 17.84 .0031 18.84 .0028 19.83 .0018 20.83 .0015 21.82 .0010 22.80 .0010
- 23.80 .0005 24.79 .0007 25.77 .0004 26.77 .0005 27.76 .0003 28.75 .0003 29.74 .0002 30.74 .0002
- 32.73 .0001))
-
-(define trpf-a3 '( .99 .0331 2.00 .0607 3.00 .0463 4.00 .0350 5.00 .0480 6.00 .0294 7.00 .0318
- 7.99 .0150 8.98 .0166 9.98 .0148 10.98 .0109 11.99 .0052 13.02 .0012 13.99 .0070 14.98 .0054
- 15.98 .0035 16.97 .0035 17.96 .0021 18.96 .0019 19.96 .0008 20.96 .0010 21.97 .0006 22.96 .0005
- 23.96 .0007 24.96 .0004 25.95 .0006 26.95 .0004 27.94 .0003 28.94 .0002 29.94 .0001 30.94 .0002
- 31.93 .0002 32.93 .0001))
-
-(define trpf-as3 '( 1.00 .0250 2.00 .0182 2.99 .0170 3.97 .0199 4.97 .0223 5.97 .0224 6.95 .0094
- 7.95 .0070 8.94 .0069 9.92 .0064 10.91 .0030 11.92 .0028 12.90 .0024 13.01 .0007 14.00 .0003
- 14.89 .0008 15.89 .0007 16.91 .0002 17.88 .0002 18.86 .0001 20.83 .0001))
-
-(define trpf-b3 '( 1.00 .0379 1.99 .0221 2.99 .0480 3.99 .0721 4.97 .0322 5.98 .0203 6.97 .0220
- 7.97 .0170 8.96 .0150 9.96 .0042 10.95 .0040 11.93 .0049 12.94 .0038 14.00 .0011 14.95 .0021
- 15.95 .0008 16.93 .0004 16.98 .0004 17.90 .0004 18.00 .0003 18.99 .0003 19.89 .0003 20.88 .0003
- 21.89 .0002 22.97 .0002 23.97 .0002))
-
-(define trpf-c4 '( 1.01 .0330 2.02 .0365 3.02 .0430 4.03 .0164 5.05 .0234 6.04 .0138 7.05 .0110
- 8.06 .0202 9.07 .0098 10.08 .0030 11.09 .0065 12.11 .0027 13.11 .0009 14.13 .0014 15.15 .0003
- 16.12 .0002 17.13 .0002 18.12 .0002 19.14 .0002 20.13 .0002 21.14 .0001))
-
-(define trpf-cs4 '( 1.01 .0082 2.02 .0191 3.02 .0152 4.01 .0324 5.02 .0129 6.03 .0050 7.01 .0093
- 8.01 .0031 9.01 .0036 10.00 .0017 11.01 .0010 12.00 .0004 13.02 .0004 14.03 .0003 15.02 .0002
- 16.03 .0001))
-
-(define trpf-d4 '( 1.01 .0190 2.03 .0431 3.04 .0481 4.05 .0399 5.07 .0179 6.08 .0198 7.09 .0136
- 8.10 .0081 9.12 .0041 10.10 .0011 11.15 .0016 12.16 .0014 13.17 .0007 14.18 .0005 15.20 .0003
- 16.20 .0002 17.22 .0002 19.24 .0001))
-
-(define trpf-ds4 '( 1.00 .0239 2.01 .0207 3.02 .0113 4.00 .0083 5.00 .0145 5.97 .0054 6.99 .0031
- 7.98 .0026 8.97 .0027 9.98 .0010 11.01 .0004 11.99 .0004 13.00 .0003 13.97 .0002 14.98 .0002
- 15.97 .0002))
-
-(define trpf-e4 '( 1.02 .0134 2.03 .0124 3.04 .0117 4.05 .0041 5.08 .0007 6.06 .0009 7.08 .0006
- 8.06 .0002 9.11 .0002))
-
-(define trpf-f4 '( 1.03 .0045 2.03 .0019 3.03 .0006 4.04 .0012 5.02 .0004 6.08 .0001))
-
-(define trpf-fs4 '( 1.00 .0501 2.00 .0385 3.00 .0509 3.99 .0156 4.98 .0099 5.98 .0063 6.99 .0017
- 7.97 .0020 8.97 .0017 9.96 .0012 10.96 .0004 11.95 .0004 12.97 .0001 13.94 .0002))
-
-(define trpf-g4 '( 1.00 .0998 2.00 .0632 3.01 .0506 4.01 .0395 5.00 .0265 6.01 .0137 7.01 .0058
- 8.01 .0017 9.02 .0010 10.02 .0007 11.02 .0007 12.03 .0004 13.03 .0004 14.03 .0002 15.05 .0001))
-
-(define trpf-gs4 '( 1.00 .0589 2.00 .0237 2.99 .0208 3.98 .0103 4.98 .0087 5.98 .0053 6.97 .0039
- 7.98 .0017 8.98 .0006 10.00 .0003 10.97 .0002 12.00 .0001))
-
-(define trpf-a4 '( 1.01 .0482 2.01 .0264 3.02 .0127 4.01 .0108 5.01 .0039 6.01 .0012 7.00 .0012
- 8.01 .0004 9.02 .0002 10.02 .0002 11.00 .0001))
-
-(define trpf-as4 '( 1.00 .0176 2.01 .0156 3.00 .0312 3.99 .0057 5.00 .0055 5.99 .0036 6.99 .0007
- 7.99 .0005 8.99 .0003 9.99 .0001 10.99 .0001))
-
-(define trpf-b4 '( 1.01 .0051 1.99 .0340 2.98 .0087 3.97 .0121 4.97 .0018 5.94 .0018 6.95 .0005
- 7.93 .0002 8.94 .0004))
-
-(define trpf-c5 '( 1.01 .0110 1.99 .0059 3.00 .0200 3.99 .0059 5.00 .0016 5.99 .0005 6.98 .0002
- 7.96 .0002 8.99 .0002))
-
-(define trpf-cs5 '( 1.01 .0257 2.01 .0215 3.02 .0022 4.00 .0027 5.01 .0007 6.00 .0007 7.02 .0002))
-
-(define trpf-d5 '( 1.01 .0616 2.01 .0423 3.01 .0140 4.01 .0061 4.99 .0034 5.99 .0008 6.98 .0006
- 8.00 .0003 8.97 .0002))
-
-(define trpf-ds5 '( .99 .0763 1.99 .0800 2.98 .0329 3.97 .0255 4.96 .0110 5.95 .0041 6.95 .0018
- 7.94 .0006 8.93 .0005 9.90 .0002 9.93 .0002 10.91 .0002))
-
-(define trpf-e5 '( 1.01 .0196 2.00 .0085 2.98 .0039 3.97 .0007 4.98 .0003))
-
-(define trpf-f5 '( 1.02 .0735 2.03 .0526 3.04 .0168 4.05 .0064 5.07 .0009 6.07 .0008 7.09 .0002
- 8.09 .0001 9.12 .0001))
-
-(define trpf-fs5 '( 1.01 .1101 2.02 .0477 3.03 .0090 4.04 .0024 5.05 .0012 6.06 .0015 7.07 .0004
- 8.08 .0002))
-
-(define trpf-g5 '( 1.02 .1148 2.03 .0215 3.04 .0185 4.06 .0077 5.07 .0023 6.08 .0007 7.09 .0004
- 8.12 .0002))
-
-(define trpf-gs5 '( 1.01 .0538 2.02 .0584 3.03 .0156 4.04 .0028 5.06 .0009 6.07 .0006 7.07 .0002))
-
-(define trpf-a5 '( 1.01 .1885 2.02 .0789 3.04 .0214 4.05 .0086 5.06 .0049 6.07 .0010 7.08 .0007
- 8.10 .0003 9.11 .0003 10.12 .0001 11.13 .0001))
-
-(define trpf-as5 '( 1.01 .0233 2.02 .0033 3.01 .0008 4.03 .0002))
-
-(define trpf-b5 '( 1.00 .1077 2.01 .0158 3.01 .0039 4.01 .0011 5.01 .0003 6.02 .0002 7.02 .0001))
-
-(define trpf-c6 '( 1.01 .0873 2.02 .0519 3.03 .0156 4.04 .0042 5.04 .0019 6.05 .0006 7.06 .0004
- 8.07 .0002))
-
-(define trpf-cs6 '( 1.01 .0852 2.02 .0049 3.03 .0007 4.05 .0001))
-
-;;;
-;;;
-;;;
-;;;
-;;; violin?
-(define vl-g3 '( .99 .0159 1.99 .1898 3.00 .0499 3.99 .0352 5.00 .0192 6.00 .0100 7.00 .0173
- 8.00 .0142 8.99 .0045 10.01 .0178 11.00 .0108 12.00 .0081 12.99 .0254 13.99 .0074 14.99 .0062
- 16.00 .0122 17.00 .0049 17.99 .0022 19.01 .0041 20.01 .0048 21.01 .0037 22.01 .0016 23.01 .0001
- 24.00 .0002 25.00 .0006 26.00 .0010 27.00 .0015 28.03 .0004 29.02 .0007 30.01 .0006 32.00 .0002
- 33.01 .0001 34.00 .0001 35.01 .0004 36.02 .0003 37.02 .0001 40.02 .0001 40.99 .0002 42.01 .0003
- 48.01 .0001 51.01 .0001))
-
-(define vl-gs3 '( .99 .0185 1.99 .1881 2.97 .0463 3.97 .0528 4.97 .0309 5.95 .0316 6.95 .0104
- 7.93 .0422 8.94 .0114 9.90 .0018 10.92 .0088 11.89 .0021 12.90 .0077 13.91 .0044 14.86 .0029
- 14.93 .0028 15.91 .0011 16.88 .0082 17.89 .0022 18.88 .0043 19.86 .0024 20.84 .0012 21.84 .0007
- 22.87 .0008 23.85 .0006 24.84 .0004 25.82 .0010 26.81 .0006 27.81 .0012 28.79 .0002 29.78 .0002
- 30.77 .0001 31.78 .0003 33.75 .0001 34.76 .0002 35.75 .0002 36.75 .0002 37.77 .0001 40.74 .0001))
-
-(define vl-a3 '( .99 .0215 2.00 .1550 2.99 .0293 4.00 .0298 5.00 .0211 6.00 .0389 7.00 .0057
- 7.99 .0235 8.99 .0172 9.99 .0040 11.00 .0026 12.00 .0074 12.99 .0065 13.99 .0192 14.99 .0026
- 15.98 .0063 16.99 .0045 18.01 .0036 18.99 .0050 20.00 .0012 20.98 .0011 21.99 .0007 22.99 .0014
- 23.99 .0003 25.00 .0011 26.00 .0008 26.99 .0007 27.98 .0002 28.99 .0001 29.97 .0004 31.00 .0002
- 31.99 .0002 32.99 .0002 33.98 .0001 35.03 .0001 36.00 .0002 36.98 .0003 37.99 .0002 38.99 .0001
- 39.99 .0002 41.01 .0001 41.99 .0001 43.04 .0001 43.99 .0001))
-
-(define vl-as3 '( 1.00 .0210 2.00 .1015 3.00 .0450 3.99 .0210 4.99 .0266 6.00 .0143 7.00 .0661
- 7.99 .0367 8.99 .0149 9.99 .0037 10.99 .0344 11.99 .0069 12.99 .0110 13.98 .0088 14.98 .0052
- 15.98 .0066 16.99 .0038 17.98 .0027 18.98 .0007 19.98 .0018 20.98 .0009 21.99 .0011 22.99 .0013
- 23.99 .0006 24.97 .0004 25.98 .0001 26.98 .0003 27.97 .0002 28.99 .0002 29.97 .0002 31.00 .0002
- 31.97 .0004 32.97 .0001 33.99 .0003 34.97 .0002 35.97 .0003 36.94 .0001 37.99 .0001 38.96 .0001
- 41.97 .0001))
-
-(define vl-b3 '( 1.00 .0532 1.99 .0205 3.00 .0342 3.99 .0312 5.00 .0493 5.99 .0062 6.99 .0103
- 7.99 .0240 8.99 .0134 9.99 .0046 10.98 .0154 11.99 .0077 12.98 .0084 13.99 .0028 14.99 .0026
- 15.98 .0054 16.98 .0031 17.99 .0004 18.98 .0009 19.99 .0005 20.52 .0001 21.98 .0011 22.97 .0010
- 23.99 .0004 24.96 .0003 26.00 .0001 27.99 .0006 28.99 .0001 30.97 .0003 32.00 .0002 32.99 .0001
- 33.97 .0002 36.99 .0001))
-
-(define vl-c4 '( .99 .1156 2.00 .0827 3.00 .0458 4.00 .0163 5.00 .0256 6.01 .0103 7.02 .0032
- 8.00 .0025 8.98 .0056 10.00 .0072 10.98 .0016 11.98 .0036 13.02 .0013 14.00 .0021 15.00 .0024
- 15.99 .0013 16.99 .0003 18.01 .0001 19.01 .0003 19.99 .0001 21.02 .0001 22.03 .0002 29.00 .0001))
-
-(define vl-cs4 '( 1.00 .3269 2.00 .0869 2.99 .0386 4.00 .0117 4.99 .0062 6.00 .0264 7.00 .0099
- 8.00 .0038 9.01 .0040 10.00 .0057 11.03 .0040 12.02 .0017 13.00 .0009 14.02 .0026 15.02 .0009
- 15.95 .0002 16.99 .0002 18.01 .0001 19.01 .0005 20.00 .0001 21.03 .0002 22.03 .0001))
-
-(define vl-d4 '( 1.00 .2473 2.00 .0621 2.98 .0073 3.99 .0178 5.00 .0070 5.98 .0041 7.02 .0054
- 8.01 .0114 9.05 .0034 10.05 .0024 10.93 .0003 11.99 .0011 13.00 .0011 14.03 .0010 15.01 .0002
- 15.96 .0001 17.02 .0001 18.01 .0005 21.00 .0001 22.00 .0002))
-
-(define vl-ds4 '( 1.00 .0394 2.00 .0358 2.99 .0119 3.99 .0208 4.99 .0064 5.98 .0126 6.96 .0028
- 7.03 .0017 8.01 .0006 8.92 .0005 9.97 .0048 10.97 .0004 11.99 .0005 12.97 .0005 13.96 .0002
- 14.92 .0001 15.92 .0001 19.93 .0001 22.92 .0001 23.96 .0001))
-
-(define vl-e4 '( 1.00 .0649 2.00 .0412 3.01 .0315 4.00 .0446 5.01 .0414 6.01 .0209 7.02 .0189
- 8.01 .0101 9.03 .0012 10.03 .0029 11.02 .0041 12.00 .0012 13.04 .0004 14.05 .0005 15.03 .0009
- 16.06 .0005 17.09 .0004 18.07 .0006 19.08 .0004 20.10 .0001 21.09 .0001 22.09 .0004 23.11 .0002
- 24.06 .0002 25.07 .0002 26.07 .0002 27.08 .0002 30.10 .0001))
-
-(define vl-f4 '( 1.00 .0700 2.00 .0235 3.00 .0294 4.00 .0101 4.99 .0173 5.99 .0081 6.99 .0023
- 7.99 .0006 8.97 .0101 9.98 .0060 11.00 .0063 11.99 .0038 13.00 .0011 13.98 .0003 15.01 .0009
- 16.02 .0005 17.01 .0004 18.06 .0002 19.01 .0004 20.01 .0004 21.03 .0005 22.04 .0002 23.00 .0003
- 24.00 .0001 25.99 .0001 29.04 .0001 31.04 .0001))
-
-(define vl-fs4 '( 1.01 .1897 2.02 .0152 3.02 .0312 4.03 .0224 5.03 .0483 6.04 .0217 7.05 .0184
- 8.07 .0051 9.06 .0031 10.08 .0047 11.09 .0040 12.10 .0021 13.10 .0006 14.11 .0010 15.14 .0012
- 16.14 .0009 17.15 .0004 18.16 .0010 19.18 .0003 20.19 .0005 21.14 .0002 22.17 .0002 23.18 .0002
- 24.18 .0002 26.22 .0001 29.25 .0002 30.26 .0002))
-
-(define vl-g4 '( 1.01 .0788 2.01 .0144 2.99 .0064 3.99 .0078 5.02 .0053 6.00 .0045 7.01 .0011
- 7.98 .0025 9.03 .0010 10.02 .0014 11.02 .0002 12.02 .0001 13.02 .0003 14.05 .0002 15.07 .0002
- 17.05 .0001 18.02 .0002 19.07 .0001))
-
-(define vl-gs4 '( 1.00 .2902 2.01 .0644 3.01 .0378 4.02 .0473 5.02 .0027 6.03 .0278 7.04 .0077
- 8.04 .0105 9.04 .0026 10.04 .0106 11.05 .0011 12.05 .0014 13.06 .0045 14.09 .0015 15.09 .0010
- 16.09 .0008 17.09 .0011 18.10 .0010 19.09 .0011 20.09 .0004 21.10 .0010 22.10 .0006 23.11 .0003
- 24.10 .0002 24.14 .0002 25.15 .0002 26.14 .0005 27.14 .0003 30.13 .0002 31.14 .0001))
-
-(define vl-a4 '( 1.00 .3420 2.02 .0045 3.00 .0160 4.00 .0105 5.01 .0370 6.02 .0193 7.01 .0342
- 8.02 .0178 9.02 .0146 10.04 .0025 11.03 .0011 12.02 .0010 13.03 .0009 14.03 .0003 15.05 .0031
- 16.04 .0009 17.04 .0004 18.04 .0004 19.03 .0004 20.06 .0005 21.05 .0001 22.04 .0001 24.06 .0001
- 25.07 .0002 26.08 .0001))
-
-(define vl-as4 '( 1.00 .1478 2.00 .0159 3.00 .0033 3.99 .0600 5.00 .0291 5.99 .0028 7.01 .0118
- 8.00 .0115 8.99 .0039 9.99 .0020 10.99 .0024 11.99 .0012 12.99 .0009 14.01 .0011 15.00 .0015
- 16.01 .0004 17.02 .0001 18.01 .0001 19.01 .0002 20.00 .0002 20.98 .0001 22.00 .0001 24.02 .0002
- 25.00 .0002))
-
-(define vl-b4 '( 1.00 .0247 2.01 .0570 3.01 .0115 4.02 .0167 5.02 .0162 6.02 .0154 7.02 .0056
- 8.04 .0021 9.04 .0003 10.04 .0023 11.04 .0003 12.07 .0005 13.09 .0005 14.06 .0003 15.06 .0004
- 16.09 .0003 17.07 .0002 18.10 .0003 19.10 .0002))
-
-(define vl-c5 '( 1.00 .0690 1.99 .0372 2.99 .0326 3.99 .0222 4.99 .0107 5.97 .0033 6.99 .0029
- 7.98 .0013 8.97 .0005 9.98 .0008 10.97 .0004 11.97 .0006 12.99 .0003 13.99 .0002 14.97 .0001
- 16.95 .0001 16.98 .0001 17.97 .0001 19.96 .0001))
-
-(define vl-cs5 '( 1.00 .1446 2.01 .0499 3.01 .0768 4.02 .0436 5.02 .0287 6.03 .0204 7.03 .0301
- 7.11 .0011 8.04 .0010 9.04 .0036 10.05 .0030 11.05 .0023 12.06 .0008 13.06 .0005 14.07 .0009
- 15.08 .0005 16.09 .0009 17.08 .0003 18.10 .0006 19.09 .0008 20.13 .0002 21.11 .0001 22.14 .0001
- 23.11 .0002))
-
-(define vl-d5 '( 1.00 .0614 1.99 .0194 2.99 .0196 3.99 .0159 5.00 .0057 6.00 .0031 7.01 .0024
- 8.00 .0004 9.00 .0003 9.98 .0003 11.01 .0005 11.99 .0003 12.99 .0002 16.99 .0001 17.98 .0001))
-
-(define vl-ds5 '( .99 .1393 1.99 .0875 2.99 .1163 3.98 .0152 4.98 .0551 5.97 .0214 6.97 .0072
- 7.96 .0017 8.95 .0028 9.96 .0034 10.95 .0015 11.94 .0010 12.95 .0009 13.91 .0008 14.94 .0011
- 15.93 .0005 16.93 .0007 17.92 .0004 17.97 .0002 18.94 .0002 19.93 .0003 20.92 .0004 21.90 .0001))
-
-(define vl-e5 '( 1.00 .1926 2.00 .0731 3.00 .0543 4.00 .0258 5.02 .0238 6.02 .0177 7.03 .0206
- 8.03 .0081 9.03 .0030 10.05 .0043 11.03 .0011 12.06 .0007 13.08 .0013 14.10 .0007 15.11 .0004
- 16.14 .0002))
-
-(define vl-f5 '( 1.00 .0684 2.00 .0409 3.00 .0344 4.00 .0439 5.00 .0686 6.00 .0504 7.00 .0045
- 8.00 .0056 9.00 .0094 10.00 .0028 11.00 .0015 11.99 .0010 13.00 .0032 14.00 .0017 15.00 .0010
- 16.01 .0011 16.99 .0003 18.01 .0006 19.00 .0003))
-
-(define vl-fs5 '( 1.00 .0291 2.01 .0323 3.01 .0110 4.02 .0071 5.04 .0028 6.04 .0010 7.08 .0007
- 8.08 .0003 9.09 .0004 10.12 .0002 11.06 .0003))
-
-(define vl-g5 '( 1.00 .0980 1.99 .0303 3.00 .0044 4.01 .0107 5.03 .0027 6.03 .0011 7.00 .0010
- 8.02 .0011 8.06 .0004 9.04 .0003 10.04 .0001))
-
-(define vl-gs5 '( 1.01 .1116 2.01 .0200 3.03 .0147 4.03 .0034 5.08 .0061 6.10 .0012 7.06 .0005
- 8.14 .0005 9.14 .0004))
-
-(define vl-a5 '( 1.00 .0211 2.01 .0180 3.01 .0158 4.02 .0057 5.03 .0013 6.03 .0006 7.02 .0001))
-
-(define vl-as5 '( 1.00 .0442 2.01 .0922 3.01 .0102 4.00 .0031 5.03 .0053 6.01 .0004 7.04 .0018
- 7.08 .0009 8.06 .0004 9.06 .0006 10.06 .0003 11.06 .0003 12.09 .0002 13.09 .0002))
-
-(define vl-b5 '( 1.01 .0061 2.01 .0016 3.01 .0014 4.03 .0005 5.04 .0005 5.06 .0001))
-
-(define vl-c6 '( 1.01 .0039 2.00 .0005 3.02 .0006 4.03 .0001))
-
-(define vl-cs6 '( 1.00 .0754 2.00 .1620 3.00 .1551 4.00 .0277 5.00 .0466 6.00 .0408 7.00 .0025
- 8.00 .0055 9.00 .0048 9.99 .0034 10.99 .0039 11.99 .0005))
-
-(define vl-d6 '( 1.00 .0905 2.00 .0808 3.00 .0909 4.00 .0616 5.00 .0172 5.99 .0043 7.01 .0044
- 8.00 .0036 9.00 .0043 10.01 .0015 11.03 .0014))
-
-(define vl-ds6 '( 1.00 .1772 2.00 .1029 3.00 .0398 4.01 .0602 5.00 .0222 6.01 .0073 7.01 .0037
- 8.01 .0044 9.01 .0019 10.01 .0028 11.01 .0006 11.03 .0001))
-
-(define vl-e6 '( 1.00 .1865 2.00 .2083 2.99 .0822 3.99 .0298 4.99 .0227 6.00 .0023 6.98 .0049
- 7.99 .0021 8.98 .0022 9.98 .0003 9.99 .0003))
-
-(define vl-f6 '( 1.01 .0841 2.01 .0654 3.02 .1346 4.03 .0041 5.04 .0077 6.05 .0088 7.05 .0016
- 8.06 .0017 9.06 .0012 9.08 .0003 9.10 .0002 9.11 .0001))
-
-(define vl-fs6 '( 1.00 .1693 2.02 .0779 3.03 .0411 4.03 .0147 5.04 .0085 6.05 .0080 7.06 .0088
- 8.06 .0032 9.06 .0010 9.08 .0007 9.10 .0004))
-
-(define vl-g6 '( 1.01 .2123 2.02 .2854 3.03 .0552 4.04 .0246 5.05 .0058 6.06 .0022 7.07 .0017
- 8.09 .0029 9.10 .0001))
-
-(define vl-gs6 '( 1.02 .1270 2.03 .0961 3.05 .0347 4.06 .0032 5.08 .0083 6.09 .0050 7.11 .0020
- 8.12 .0013 8.14 .0002))
-
-(define vl-a6 '( 1.02 .3359 2.03 .1252 3.05 .0238 4.07 .0155 5.09 .0053 6.10 .0051 7.12 .0025
- 7.18 .0001))
-
-(define vl-as6 '( 1.01 .2037 2.03 .0456 3.05 .0029 4.06 .0053 5.07 .0041 6.09 .0043 7.11 .0026
- 7.13 .0006 7.14 .0001))
-
-(define vl-b6 '( 1.02 .4213 2.04 .1379 3.06 .0067 4.06 .0041 4.08 .0039 5.09 .0026 6.11 .0027
- 7.13 .0002))
-
-(define vl-c7 '( 1.01 .1299 2.02 .1571 3.03 .0461 4.04 .0033 5.05 .0057 6.06 .0015))
-
-(define vl-cs7 '( 1.01 .1471 2.03 .0526 3.05 .0161 4.06 .0037 5.08 .0017 6.09 .0005))
-
-(define vl-d7 '( 1.01 .0321 2.02 .0529 3.03 .0046 4.03 .0054 4.04 .0021 5.04 .0010))
-
-(define vl-ds7 '( 1.00 .1220 2.00 .0667 2.99 .0319 4.00 .0020 4.99 .0052 5.03 .0002))
-
-(define vl-e7 '( 1.01 .1110 2.02 .0588 3.03 .0143 4.04 .0068 5.05 .0011))
-
-(define vl-f7 '( 1.01 .0798 2.02 .0111 3.03 .0125 4.03 .0036 4.50 .0002 5.04 .0001))
-
-(define vl-fs7 '( 1.02 .1071 2.04 .0117 3.06 .0148 4.08 .0092 4.11 .0007 4.13 .0005 4.16 .0003
- 4.23 .0002 4.24 .0002 4.28 .0002 4.34 .0001 4.39 .0001))
-
-(define vl-g7 '( 1.02 .2741 2.05 .0256 3.07 .0122 4.11 .0002 4.14 .0001))
-
-(define vl-gs7 '( 1.02 .1027 2.05 .0192 3.07 .0091))
-
-(define vl-a7 '( 1.02 .0796 2.04 .0112 3.06 .0030))
-
-(define vl-as7 '( 1.06 .1256))
-
-(define vl-b7 '( 1.08 .1494 3.24 .0003))
-
-(define vl-c8 '( 1.07 .0582 3.25 .0004))
-
-(define vl-cs8 '( 1.08 .0889))
-
-(define vl-d8 '( 1.07 .0573))
-
-
-;;;
-;;;
-;;;
-;;;
-;;;
-(define almf-c3 '( 1.01 .0037 2.01 .0482 3.01 .0275 4.01 .0182 5.03 .0047 6.03 .0032 7.03 .0005
- 8.03 .0050 9.05 .0044 10.02 .0016 11.06 .0011 12.06 .0004 13.06 .0006 14.16 .0001 15.12 .0001
- 16.12 .0004 17.12 .0004 19.08 .0003 20.11 .0004 23.11 .0002 24.14 .0003 25.14 .0003 27.12 .0002
- 28.13 .0001 30.17 .0001))
-
-(define almf-cs3 '( 1.01 .0043 2.01 .0357 3.02 .0452 4.01 .0156 5.02 .0152 6.04 .0022 7.04 .0039
- 8.06 .0078 9.06 .0049 10.09 .0046 11.24 .0004 12.08 .0016 13.09 .0015 14.10 .0021 15.12 .0006
- 16.12 .0012 17.12 .0002 18.16 .0004 19.16 .0006 20.15 .0006 21.15 .0007 22.16 .0005 23.17 .0005
- 24.13 .0004 25.48 .0003 26.19 .0002 27.18 .0002 28.20 .0002 30.26 .0001 31.25 .0002 34.23 .0001))
-
-(define almf-d3 '( 1.01 .0052 2.03 .0062 3.01 .0292 4.05 .0043 5.02 .0149 5.97 .0018 7.02 .0016
- 8.05 .0029 9.04 .0005 10.06 .0012 11.04 .0006 12.12 .0002 13.05 .0005 14.10 .0004 15.08 .0004
- 15.99 .0001 17.18 .0001 18.07 .0004 19.06 .0001 20.08 .0003 22.11 .0003 24.13 .0002 25.15 .0001
- 26.12 .0001))
-
-(define almf-ds3 '( 1.01 .0043 2.01 .0532 3.01 .0389 4.00 .0094 5.01 .0031 6.00 .0038 7.00 .0219
- 8.00 .0122 8.99 .0129 10.00 .0014 11.00 .0021 12.01 .0037 13.01 .0021 14.01 .0017 15.02 .0015
- 16.01 .0023 17.03 .0024 18.00 .0008 19.03 .0011 20.04 .0003 21.04 .0009 22.04 .0003 23.00 .0012
- 24.00 .0011 25.01 .0007 27.02 .0002 28.02 .0004 29.03 .0003 30.04 .0002 31.04 .0001 46.55 .0001
- 48.01 .0001))
-
-(define almf-e3 '( 1.00 .0123 2.00 .0733 2.99 .0330 4.00 .0098 5.00 .0171 6.00 .0013 7.01 .0117
- 7.99 .0020 9.00 .0044 10.01 .0012 11.01 .0014 12.00 .0021 13.02 .0002 14.02 .0016 15.03 .0012
- 16.03 .0028 17.02 .0007 18.02 .0019 19.03 .0008 20.04 .0013 21.03 .0005 22.03 .0005 23.03 .0003
- 24.04 .0003 26.03 .0005 27.04 .0001 28.06 .0001 29.04 .0002))
-
-(define almf-f3 '( 1.00 .0185 2.00 .0813 3.00 .0142 3.99 .0132 5.00 .0066 5.99 .0027 6.93 .0009
- 8.01 .0042 8.99 .0018 9.97 .0002 10.97 .0010 12.00 .0008 13.00 .0012 13.98 .0003 14.96 .0006
- 16.00 .0004 17.01 .0005 18.00 .0003 18.98 .0005 19.99 .0002 20.99 .0002 22.00 .0002))
-
-(define almf-fs3 '( 1.01 .0480 2.01 .0778 3.01 .0124 4.01 .0204 5.05 .0008 6.03 .0068 7.05 .0052
- 8.06 .0017 9.07 .0017 10.05 .0008 11.07 .0010 12.08 .0008 13.11 .0002 14.08 .0006 15.10 .0002
- 16.09 .0013 17.12 .0003 18.10 .0003 19.11 .0004 20.14 .0001 23.17 .0001))
-
-(define almf-g3 '( 1.00 .0526 2.00 .0242 2.99 .0351 3.99 .0076 4.98 .0062 5.99 .0085 6.99 .0061
- 8.04 .0006 8.98 .0005 10.01 .0006 10.97 .0003 11.96 .0004 13.07 .0004 13.95 .0003 14.99 .0003
- 15.20 .0002 17.93 .0002 18.02 .0002 24.96 .0001))
-
-(define almf-gs3 '( .99 .0523 1.99 .0560 2.98 .0166 3.98 .0183 4.96 .0005 5.98 .0066 6.99 .0026
- 7.96 .0011 8.95 .0013 9.95 .0026 10.95 .0019 11.96 .0017 12.94 .0005 13.92 .0002 14.94 .0006
- 15.95 .0007 16.94 .0007 17.96 .0002 18.92 .0002 19.93 .0002 20.92 .0002 21.94 .0001))
-
-(define almf-a3 '( 1.00 .1590 2.00 .0394 3.02 .0076 3.99 .0222 5.00 .0063 5.93 .0008 6.97 .0016
- 7.95 .0002 8.94 .0002 9.94 .0003 10.05 .0002 10.15 .0001 12.00 .0005 12.12 .0002 12.95 .0001
- 15.98 .0002))
-
-(define almf-as3 '( 1.00 .2533 2.00 .0498 3.00 .0178 3.99 .0108 5.00 .0245 6.00 .0112 6.99 .0066
- 8.00 .0010 8.98 .0074 9.99 .0042 10.99 .0025 12.00 .0015 13.01 .0006 14.00 .0012 15.00 .0004
- 16.02 .0004 17.00 .0010 18.00 .0005 18.99 .0002 19.98 .0002))
-
-(define almf-b3 '( 1.00 .1639 2.00 .0436 3.01 .0584 4.01 .0080 5.01 .0117 6.01 .0208 7.02 .0062
- 8.02 .0035 9.03 .0037 10.03 .0022 11.04 .0023 12.04 .0048 13.04 .0022 14.04 .0005 15.04 .0007
- 16.05 .0012 17.05 .0010 18.06 .0005 19.05 .0001 20.06 .0005 21.07 .0002 24.07 .0002 25.08 .0002
- 27.08 .0002 28.10 .0001 33.12 .0001))
-
-(define almf-c4 '( 1.00 .0931 2.00 .0251 3.00 .0077 4.00 .0129 5.00 .0115 6.00 .0055 7.00 .0041
- 8.01 .0046 9.00 .0013 10.00 .0067 11.02 .0011 12.02 .0021 12.99 .0002 14.01 .0007 15.02 .0008
- 16.03 .0007 17.02 .0004 19.02 .0003 20.05 .0001 24.04 .0001))
-
-(define almf-cs4 '( 1.01 .0587 2.01 .0263 3.02 .0299 4.03 .0306 5.04 .0172 6.04 .0097 7.05 .0024
- 8.06 .0034 9.06 .0053 10.07 .0065 11.08 .0025 12.09 .0005 13.10 .0016 14.11 .0011 15.11 .0009
- 16.12 .0004 17.13 .0002 18.13 .0003 21.15 .0002 23.17 .0001 24.18 .0001 25.19 .0002 30.23 .0001
- 32.25 .0001))
-
-(define almf-d4 '( 1.00 .0619 2.00 .0432 3.01 .0479 4.01 .0136 5.00 .0220 6.01 .0064 7.02 .0138
- 8.02 .0033 9.02 .0066 10.06 .0006 11.02 .0019 12.01 .0013 13.02 .0008 14.01 .0004 15.03 .0007
- 16.04 .0003 17.03 .0001 18.02 .0001 21.04 .0003))
-
-(define almf-ds4 '( 1.00 .0762 1.99 .0071 2.99 .0085 3.99 .0120 4.98 .0064 5.98 .0018 6.98 .0039
- 7.99 .0027 8.96 .0017 9.95 .0007 10.98 .0006 11.95 .0003 12.98 .0006 13.98 .0007 15.97 .0002
- 19.96 .0001))
-
-(define almf-e4 '( .99 .0726 1.99 .0195 2.99 .0147 3.98 .0106 4.99 .0069 6.00 .0026 6.99 .0046
- 7.99 .0105 8.97 .0017 10.01 .0007 10.97 .0022 11.99 .0009 12.99 .0011 13.98 .0001 14.96 .0002
- 15.96 .0001 16.99 .0001 17.95 .0002 18.98 .0002 20.98 .0001 21.97 .0001))
-
-(define almf-f4 '( 1.00 .0772 2.00 .0150 3.00 .0166 4.01 .0118 4.99 .0024 6.01 .0067 7.03 .0017
- 8.00 .0012 9.02 .0017 10.02 .0011 11.03 .0008 12.04 .0004 13.04 .0007 14.03 .0002 15.04 .0002
- 16.04 .0001))
-
-(define almf-fs4 '( .99 .1309 1.99 .0550 2.98 .0321 3.98 .0270 4.97 .0070 5.97 .0099 6.96 .0041
- 7.96 .0033 8.95 .0023 9.94 .0017 10.94 .0023 11.93 .0015 12.93 .0006 13.95 .0002 14.93 .0002
- 15.91 .0002 16.91 .0003 17.92 .0001 18.90 .0003 19.93 .0001 22.87 .0001 23.88 .0001))
-
-(define almf-g4 '( .99 .0515 2.00 .0153 3.00 .0281 4.00 .0071 5.01 .0020 6.00 .0045 7.02 .0006
- 8.00 .0054 8.99 .0020 10.00 .0031 11.01 .0023 12.02 .0003 13.00 .0004 14.01 .0002 15.02 .0003
- 15.98 .0002 16.02 .0002 18.03 .0002 19.01 .0001))
-
-(define almf-gs4 '( 1.00 .0592 2.00 .0287 3.00 .0196 3.99 .0175 4.99 .0168 6.00 .0071 6.07 .0008
- 7.00 .0003 7.99 .0019 8.98 .0007 9.98 .0012 10.99 .0012 11.98 .0004 12.98 .0003 13.99 .0002
- 14.96 .0001 15.98 .0001 16.97 .0002 17.96 .0002))
-
-(define almf-a4 '( 1.01 .0784 2.01 .0480 3.02 .0131 4.02 .0074 5.03 .0141 6.03 .0173 7.04 .0070
- 8.04 .0033 9.06 .0154 9.12 .0016 10.07 .0011 11.07 .0013 12.07 .0009 13.09 .0008 14.07 .0006
- 15.09 .0002 16.10 .0005 17.10 .0003 19.12 .0001 23.14 .0001))
-
-(define almf-as4 '( 1.00 .0507 2.00 .0304 3.00 .0303 4.00 .0084 5.00 .0072 6.00 .0098 6.99 .0058
- 8.01 .0036 9.01 .0023 10.00 .0010 11.00 .0008 12.00 .0007 12.97 .0005 13.02 .0004 14.00 .0003
- 14.99 .0003 16.01 .0001 17.01 .0002 18.00 .0001 20.01 .0001))
-
-(define almf-b4 '( 1.00 .0340 2.00 .0113 3.01 .0098 4.02 .0033 5.03 .0013 6.05 .0008 7.02 .0007
- 8.07 .0006 9.01 .0001))
-
-(define almf-c5 '( 1.00 .0384 2.00 .0426 3.01 .0092 4.02 .0239 5.02 .0184 6.02 .0031 7.03 .0029
- 8.04 .0016 8.10 .0006 9.04 .0005 10.04 .0003 11.05 .0006 12.05 .0007 13.06 .0002 15.07 .0002))
-
-(define almf-cs5 '( 1.00 .0159 2.00 .0592 3.00 .0390 4.00 .0272 5.00 .0121 6.00 .0032 7.01 .0124
- 8.01 .0055 9.00 .0009 10.01 .0016 11.01 .0007 12.01 .0006 13.02 .0020 14.02 .0010 15.02 .0007
- 16.03 .0004 17.03 .0002 18.02 .0001 19.03 .0001 20.03 .0003 21.03 .0002 22.03 .0003 23.03 .0002))
-
-(define almf-d5 '( 1.01 .0376 2.01 .0409 3.02 .0136 4.03 .0016 5.05 .0080 6.05 .0044 7.06 .0036
- 8.07 .0018 9.07 .0007 10.08 .0011 11.09 .0002 12.09 .0004 13.12 .0003 14.11 .0001 16.15 .0002
- 17.16 .0001 20.18 .0001))
-
-(define almf-ds5 '( 1.00 .0391 2.01 .0445 3.01 .0188 4.02 .0329 5.02 .0185 6.02 .0311 7.03 .0107
- 8.03 .0032 9.03 .0010 10.03 .0009 11.04 .0019 12.04 .0019 13.05 .0005 14.06 .0004 15.05 .0007
- 16.06 .0002 17.07 .0002 18.08 .0002 19.07 .0005 20.07 .0003 21.08 .0001))
-
-(define almf-e5 '( 1.00 .0869 2.00 .0181 3.01 .0252 4.01 .0520 5.01 .0040 6.02 .0336 7.02 .0108
- 8.03 .0070 9.03 .0023 10.03 .0009 11.03 .0017 12.02 .0004 13.04 .0012 14.04 .0006 15.05 .0016
- 16.06 .0007 17.06 .0003 18.06 .0012 19.07 .0001 20.06 .0001))
-
-(define almf-f5 '( 1.01 .0905 2.02 .0649 3.02 .0406 4.03 .0295 5.04 .0038 6.05 .0088 7.06 .0009
- 8.07 .0021 9.07 .0037 10.09 .0022 11.09 .0014 12.09 .0018 13.11 .0006 14.12 .0009 15.13 .0004
- 16.12 .0003 17.14 .0006 18.15 .0002))
-
-(define almf-fs5 '( .99 .0868 1.98 .0447 2.98 .0303 3.97 .0092 4.96 .0183 5.95 .0121 6.94 .0033
- 7.95 .0010 8.92 .0022 9.92 .0007 10.91 .0007 11.90 .0007 12.89 .0014 13.87 .0004 14.88 .0006
- 14.91 .0003 15.87 .0002 16.85 .0003))
-
-(define almf-g5 '( 1.00 .0467 2.00 .0739 3.00 .0255 4.00 .0277 5.00 .0349 6.00 .0119 7.00 .0024
- 8.00 .0085 9.00 .0016 9.99 .0012 11.00 .0004 11.99 .0014 12.99 .0024 13.99 .0017 14.99 .0007
- 15.99 .0004 16.98 .0001))
-
-(define almf-gs5 '( .99 .0605 1.99 .0384 2.98 .0154 3.98 .0036 4.97 .0164 5.96 .0039 6.96 .0036
- 7.95 .0040 8.94 .0012 9.94 .0006 10.93 .0015 11.93 .0012 12.93 .0008 13.91 .0010 14.90 .0005
- 15.91 .0001))
-
-(define almf-a5 '( 1.00 .1051 2.01 .0322 3.02 .0393 4.03 .0112 5.03 .0099 6.04 .0074 7.05 .0054
- 8.05 .0030 9.06 .0019 10.07 .0006 11.07 .0023 12.08 .0004 13.08 .0005 14.09 .0006 14.11 .0001
- 15.11 .0001))
-
-(define almf-as5 '( 1.00 .0284 2.01 .0161 3.02 .0248 4.03 .0414 5.03 .0135 6.04 .0028 7.05 .0021
- 8.06 .0006 9.07 .0009 10.07 .0010 11.08 .0012 12.10 .0003 13.09 .0010 14.10 .0003))
-
-(define almf-b5 '( .99 .0354 1.98 .0173 2.97 .0086 3.96 .0204 3.99 .0077 4.03 .0067 4.06 .0037
- 4.95 .0034 5.93 .0030 5.96 .0015 5.98 .0009 6.92 .0007 7.92 .0008 8.91 .0017 9.90 .0008
- 9.93 .0006 10.88 .0003 11.91 .0003 12.86 .0004 12.90 .0002))
-
-(define almf-c6 '( 1.01 .0675 2.01 .0578 3.02 .0346 4.03 .0170 5.03 .0082 6.04 .0050 7.06 .0032
- 8.03 .0009 9.06 .0009 10.07 .0008 11.09 .0010 12.03 .0002))
-
-(define almf-cs6 '( 1.00 .0896 1.99 .0634 3.01 .0037 3.98 .0105 4.98 .0030 5.98 .0019 6.97 .0020
- 7.97 .0014 8.00 .0007 8.99 .0005 9.96 .0005 10.95 .0008 10.98 .0005 11.00 .0003 11.02 .0003
- 11.03 .0002 11.06 .0002 11.95 .0001 11.98 .0001))
-
-(define almf-d6 '( 1.00 .0593 2.00 .0364 3.01 .0142 4.01 .0065 5.02 .0063 6.01 .0024 7.02 .0010
- 8.02 .0019 9.02 .0015 10.03 .0007 11.02 .0002))
-
-(define almf-ds6 '( 1.00 .0410 1.99 .0353 2.99 .0291 3.99 .0089 4.99 .0066 5.98 .0023 6.99 .0012
- 7.96 .0011 7.99 .0006 8.94 .0004 8.98 .0003 9.95 .0001))
-
-(define almf-e6 '( 1.01 .0254 2.01 .0252 3.02 .0365 4.03 .0034 5.02 .0013 6.02 .0010 7.08 .0006
- 8.02 .0010 9.03 .0007 9.12 .0004))
-
-(define almf-f6 '( 1.00 .1896 2.00 .0411 3.00 .0216 4.00 .0019 5.00 .0032 6.01 .0012 7.02 .0007
- 7.99 .0026 9.00 .0003 9.03 .0002))
-
-(define almf-fs6 '( 1.01 .0285 2.01 .0189 3.02 .0213 4.02 .0033 5.03 .0024 6.03 .0010 7.04 .0016
- 8.05 .0015 9.05 .0003 9.06 .0002))
-
-(define almf-g6 '( 1.00 .1939 2.00 .0339 3.00 .0219 4.01 .0079 5.01 .0025 6.01 .0017 7.01 .0014
- 7.95 .0009 8.00 .0006 8.02 .0003))
-
-(define almf-gs6 '( 1.00 .1069 2.00 .0146 3.00 .0220 4.00 .0046 5.00 .0020 6.00 .0027 6.99 .0011
- 8.00 .0003))
-
-(define almf-a6 '( 1.00 .0952 1.99 .0201 3.00 .0015 3.99 .0064 4.98 .0021 5.97 .0009 6.98 .0010))
-
-(define almf-as6 '( 1.00 .0132 1.99 .0635 2.99 .0057 3.98 .0054 3.99 .0034 4.99 .0011 5.96 .0012
- 5.98 .0008 5.99 .0007 6.96 .0004 6.98 .0004))
-
-(define almf-b6 '( 1.00 .0241 2.01 .0417 3.02 .0098 3.99 .0016 4.02 .0016 5.03 .0016 6.04 .0012))
-
-(curlet)))
+ (let (
+ ;; bass clarinet?
+ (bc-c2 '(1.00 .0370 1.98 .0037 2.99 .0862 3.98 .0011 4.97 .0270 5.98 .0030 6.97 .0586
+ 7.95 .0031 8.96 .0363 9.95 .0076 10.93 .0310 11.95 .0097 12.93 .0206 13.92 .0045 14.93 .0044
+ 15.91 .0021 16.90 .0220 17.91 .0082 18.90 .0227 19.88 .0049 20.90 .0090 21.87 .0004 22.87 .0051
+ 23.88 .0010 24.86 .0072 25.85 .0026 26.86 .0044 27.84 .0035 28.85 .0031 29.84 .0025 30.83 .0042
+ 31.84 .0024 32.83 .0022 33.81 .0021 34.82 .0011 35.81 .0008 36.79 .0013 37.80 .0024 38.78 .0028
+ 39.78 .0016 40.79 .0024 41.77 .0005 42.76 .0005 43.77 .0003 44.76 .0002 45.74 .0005 46.75 .0003
+ 47.74 .0006 48.73 .0003 49.74 .0009 50.72 .0002 51.71 .0007 52.72 .0004 53.70 .0005 54.70 .0004
+ 55.71 .0005 56.69 .0002 57.68 .0003 58.69 .0002 59.68 .0002 60.68 .0003 61.68 .0002 62.66 .0002
+ 63.66 .0002 65.65 .0001 67.64 .0002 69.63 .0002 70.63 .0002 71.60 .0002 72.62 .0002 73.60 .0002
+ 75.59 .0002 76.59 .0002 77.58 .0001 78.59 .0001 79.57 .0002 80.57 .0002 81.57 .0002 82.54 .0001
+ 83.56 .0002 84.54 .0001 85.53 .0001 87.53 .0002 89.53 .0002))
+
+ (bc-cs2 '(1.02 .0306 2.00 .0016 2.99 .0926 4.00 .0027 5.01 .0305 5.99 .0006 6.99 .0158
+ 8.00 .0025 9.01 .0072 10.01 .0057 10.99 .0203 12.00 .0078 13.01 .0147 14.02 .0036 15.00 .0103
+ 16.07 .0007 17.01 .0070 18.01 .0053 19.00 .0049 20.02 .0027 21.01 .0024 22.01 .0014 23.00 .0011
+ 24.02 .0023 25.00 .0031 26.01 .0021 27.00 .0029 28.02 .0010 29.02 .0026 30.04 .0011 31.00 .0019
+ 32.01 .0010 33.03 .0004 34.02 .0002 36.02 .0004 37.05 .0002 38.04 .0004 39.00 .0003 40.02 .0002
+ 41.01 .0002 42.01 .0002 43.00 .0001 44.02 .0001 45.01 .0002 47.01 .0002 48.03 .0001 49.00 .0002
+ 50.03 .0001 51.02 .0001 55.00 .0001 56.99 .0002 73.98 .0001 75.02 .0001 75.98 .0001))
+
+ (bc-d2 '(1.01 .1419 1.97 .0009 3.00 .0865 4.01 .0008 5.00 .0059 6.00 .0009 7.00 .0110
+ 8.00 .0014 9.00 .0050 10.00 .0057 11.01 .0267 12.01 .0091 13.00 .0238 14.02 .0023 15.01 .0069
+ 16.01 .0033 17.00 .0064 18.01 .0036 18.99 .0067 20.01 .0026 21.01 .0047 22.01 .0037 22.99 .0040
+ 24.00 .0038 25.01 .0036 26.01 .0032 27.00 .0036 27.99 .0019 29.00 .0034 30.00 .0014 31.00 .0007
+ 31.98 .0003 33.04 .0002 34.05 .0003 35.04 .0003 35.95 .0002 37.05 .0003 37.98 .0002 39.07 .0002
+ 40.02 .0002 40.95 .0001 42.01 .0003 42.98 .0002 44.02 .0004 44.99 .0002 46.03 .0002 46.98 .0002
+ 48.04 .0001 49.01 .0001 51.02 .0002 52.03 .0002 53.01 .0002 54.01 .0001 55.01 .0002 56.02 .0001
+ 65.00 .0002 66.99 .0001 69.01 .0001 71.00 .0002 73.00 .0001 74.99 .0001))
+
+ (bc-ds2 '(1.01 .2718 2.01 .0016 3.01 .0476 4.01 .0022 5.01 .0228 6.00 .0005 7.01 .0466
+ 8.01 .0014 9.00 .0179 10.01 .0059 11.00 .0254 12.01 .0099 13.00 .0176 14.01 .0031 15.02 .0109
+ 16.00 .0007 17.02 .0090 18.03 .0038 19.02 .0036 20.02 .0029 21.02 .0045 22.02 .0026 23.02 .0060
+ 24.02 .0031 25.02 .0023 26.02 .0033 27.02 .0041 28.02 .0033 29.02 .0034 30.03 .0007 31.04 .0005
+ 32.03 .0005 33.05 .0005 34.03 .0006 35.05 .0002 36.04 .0004 37.03 .0002 38.03 .0003 39.03 .0004
+ 40.03 .0002 41.03 .0004 42.03 .0003 43.03 .0006 44.04 .0002 45.05 .0005 46.04 .0001 47.05 .0003
+ 48.04 .0002 49.05 .0003 50.04 .0001 51.04 .0003 52.04 .0002 53.04 .0001 55.04 .0002 57.05 .0002
+ 59.06 .0002 61.07 .0002 62.06 .0001 63.06 .0002 64.05 .0001 65.06 .0001 66.06 .0002 67.06 .0002
+ 68.06 .0002 70.06 .0002 72.06 .0001 74.08 .0001))
+
+ (bc-e2 '(1.01 .1365 2.01 .0009 3.03 .0219 3.99 .0004 5.04 .0239 6.03 .0013 7.02 .0284
+ 8.04 .0029 9.03 .0167 10.06 .0042 11.05 .0059 12.03 .0012 13.07 .0095 14.07 .0013 15.08 .0109
+ 16.06 .0038 17.06 .0042 18.09 .0006 19.07 .0034 20.10 .0036 21.09 .0018 22.08 .0025 23.11 .0054
+ 24.08 .0008 25.12 .0035 26.09 .0013 27.13 .0022 28.13 .0009 29.12 .0006 30.14 .0004 31.13 .0005
+ 32.15 .0003 33.15 .0003 35.15 .0002 36.13 .0001 37.17 .0003 38.19 .0002 39.16 .0006 40.21 .0001
+ 41.17 .0005 42.18 .0002 43.19 .0003 44.18 .0001 45.21 .0002 46.19 .0002 47.22 .0004 48.22 .0002
+ 49.20 .0002 50.23 .0001 55.24 .0001 56.23 .0001 57.26 .0002 59.26 .0001 61.25 .0002 62.29 .0002
+ 64.27 .0001))
+
+ (bc-f2 '(.99 .1014 2.00 .0021 3.02 .0301 4.02 .0012 5.00 .0893 6.02 .0028 7.03 .0333
+ 8.04 .0046 9.05 .0109 10.03 .0033 11.03 .0174 12.05 .0075 13.06 .0085 14.06 .0037 15.04 .0133
+ 16.08 .0021 17.07 .0017 18.07 .0009 19.05 .0015 20.07 .0002 21.08 .0068 22.09 .0033 23.10 .0060
+ 24.07 .0031 25.08 .0036 26.10 .0009 27.11 .0001 28.11 .0010 29.10 .0007 30.10 .0004 31.12 .0005
+ 32.13 .0002 33.11 .0005 34.11 .0003 35.12 .0004 36.13 .0002 37.14 .0005 38.12 .0001 39.14 .0005
+ 40.14 .0002 41.16 .0002 43.14 .0003 45.17 .0004 46.18 .0002 47.16 .0002 49.18 .0002 51.18 .0001
+ 53.19 .0002 55.22 .0001 56.19 .0002 57.21 .0001 58.22 .0002 60.23 .0002 62.22 .0001))
+
+ (bc-fs2 '(1.01 .0724 2.02 .0045 3.01 .0626 4.01 .0014 5.00 .1104 6.00 .0041 7.00 .0216
+ 8.03 .0017 9.03 .0255 10.02 .0011 11.02 .0152 12.02 .0019 13.01 .0061 14.02 .0018 15.04 .0077
+ 16.05 .0009 17.04 .0031 18.04 .0014 19.02 .0058 20.04 .0005 21.03 .0030 22.03 .0030 23.05 .0048
+ 24.06 .0013 25.04 .0009 26.04 .0002 27.03 .0008 28.05 .0005 29.05 .0003 30.06 .0002 31.06 .0004
+ 32.05 .0005 33.05 .0003 34.04 .0002 35.05 .0004 37.08 .0006 38.06 .0002 39.07 .0003 41.06 .0003
+ 42.07 .0001 43.07 .0003 44.09 .0002 45.10 .0001 47.07 .0001 51.10 .0002 53.10 .0002 54.10 .0001
+ 56.09 .0002 57.09 .0001 58.12 .0001 62.11 .0001 64.11 .0001))
+
+ (bc-g2 '(1.00 .0567 1.99 .0037 3.00 .1114 3.98 .0030 4.99 .1112 5.98 .0041 6.99 .0195
+ 7.99 .0061 8.98 .0081 9.97 .0084 10.98 .0139 11.98 .0038 12.98 .0092 13.97 .0038 14.97 .0042
+ 15.97 .0003 16.97 .0012 17.96 .0019 18.97 .0040 19.95 .0032 20.97 .0088 21.95 .0022 22.96 .0025
+ 23.94 .0004 24.94 .0003 25.92 .0005 26.95 .0005 27.91 .0003 28.95 .0003 29.90 .0002 30.94 .0006
+ 31.89 .0001 32.93 .0007 34.92 .0005 35.89 .0002 36.92 .0003 37.89 .0001 38.91 .0002 39.88 .0002
+ 40.90 .0004 41.88 .0002 43.88 .0002 50.90 .0001 51.89 .0002 52.93 .0001 53.89 .0003 55.87 .0002))
+
+ (bc-gs2 '(.99 .0794 2.00 .0021 3.00 .1294 3.98 .0015 4.98 .0849 5.98 .0058 6.99 .0389
+ 7.97 .0113 8.97 .0154 9.98 .0026 10.98 .0172 11.95 .0048 12.95 .0099 13.98 .0011 14.97 .0029
+ 15.95 .0013 16.95 .0055 17.97 .0014 18.96 .0052 19.94 .0040 20.94 .0038 21.96 .0006 22.94 .0003
+ 23.92 .0005 24.93 .0005 25.93 .0002 26.94 .0006 27.92 .0003 28.91 .0007 29.91 .0004 30.93 .0006
+ 31.90 .0003 32.90 .0006 33.90 .0003 34.91 .0004 35.89 .0001 36.89 .0003 37.90 .0003 38.90 .0003
+ 40.88 .0002 42.89 .0001 45.89 .0002 47.87 .0001 49.87 .0003 50.86 .0002 51.85 .0002 53.86 .0001))
+
+ (bc-a2 '(.99 .1177 1.99 .0047 2.99 .2346 3.99 .0023 4.98 .0538 5.99 .0060 6.98 .0493
+ 7.99 .0062 8.99 .0103 9.99 .0030 10.99 .0146 11.99 .0126 12.99 .0042 13.99 .0016 14.99 .0060
+ 15.98 .0034 16.96 .0039 17.96 .0036 18.96 .0076 19.96 .0018 20.96 .0025 22.95 .0018 23.95 .0005
+ 24.94 .0003 25.95 .0005 26.95 .0006 27.95 .0008 28.96 .0005 29.96 .0005 30.96 .0007 31.95 .0005
+ 32.95 .0005 33.95 .0001 34.95 .0003 35.93 .0002 36.94 .0003 38.92 .0002 42.93 .0001 44.93 .0001
+ 46.93 .0002 47.92 .0001))
+
+ (bc-as2 '(1.00 .1279 1.99 .0028 2.99 .1611 3.98 .0034 4.97 .0322 5.97 .0085 6.98 .0274
+ 7.97 .0068 8.96 .0245 9.97 .0022 10.94 .0254 11.93 .0010 12.93 .0078 13.95 .0022 14.94 .0035
+ 15.92 .0022 16.92 .0033 17.91 .0039 18.90 .0037 19.92 .0012 20.92 .0003 21.91 .0008 22.89 .0005
+ 23.88 .0007 24.87 .0007 25.87 .0005 26.88 .0007 27.86 .0001 28.86 .0014 29.84 .0004 30.85 .0005
+ 31.85 .0001 32.85 .0004 33.84 .0004 34.84 .0003 36.82 .0003 40.81 .0003 42.80 .0001 43.79 .0002
+ 44.79 .0002 45.79 .0003 46.79 .0001 47.79 .0002 49.77 .0001))
+
+ (bc-b2 '(1.00 .1161 1.98 .0036 2.97 .1813 3.98 .0038 4.96 .0298 5.95 .0073 6.95 .0125
+ 7.95 .0064 8.92 .0175 9.94 .0087 10.91 .0117 11.91 .0025 12.91 .0055 13.92 .0027 14.88 .0069
+ 15.88 .0034 16.88 .0052 17.85 .0038 18.88 .0003 19.83 .0005 20.83 .0005 21.78 .0002 22.82 .0004
+ 23.74 .0002 24.81 .0008 25.76 .0003 26.78 .0005 27.78 .0006 28.78 .0005 29.74 .0002 30.75 .0001
+ 31.75 .0004 32.72 .0002 33.73 .0002 34.73 .0002 41.69 .0002 42.68 .0002 43.67 .0002 44.68 .0002
+ 45.67 .0001))
+
+ (bc-c3 '(1.00 .1579 1.99 .0068 2.99 .1885 3.99 .0022 4.97 .0384 5.96 .0054 6.97 .0247
+ 7.97 .0023 8.96 .0114 9.95 .0096 10.93 .0054 11.95 .0030 12.94 .0036 13.92 .0075 14.93 .0033
+ 15.92 .0052 16.91 .0010 17.91 .0011 18.90 .0004 19.89 .0006 20.90 .0005 21.89 .0003 22.87 .0004
+ 23.88 .0004 24.87 .0005 25.86 .0008 26.87 .0005 27.85 .0002 28.84 .0002 29.85 .0003 30.83 .0002
+ 31.84 .0002 32.83 .0002 35.83 .0001 36.80 .0002 38.81 .0002 39.78 .0002 40.78 .0003 41.79 .0001))
+
+ (bc-cs3 '(1.00 .2106 1.98 .0073 2.99 .1027 3.98 .0038 4.97 .0191 5.98 .0036 6.97 .0256
+ 7.95 .0035 8.97 .0347 9.95 .0039 10.94 .0048 11.95 .0026 12.94 .0089 13.93 .0011 14.93 .0052
+ 15.93 .0033 16.96 .0002 17.93 .0003 18.94 .0001 19.92 .0002 20.91 .0007 21.91 .0006 22.89 .0005
+ 23.90 .0005 24.90 .0005 25.87 .0005 26.89 .0003 27.88 .0005 28.87 .0003 29.87 .0003 31.85 .0002
+ 33.84 .0001 34.84 .0001 36.82 .0003 37.83 .0001 38.83 .0003))
+
+ (bc-d3 '(1.01 .2039 2.00 .0041 3.00 .0640 3.99 .0062 5.00 .0192 6.00 .0013 7.01 .0225
+ 8.00 .0034 9.01 .0245 10.00 .0038 11.02 .0028 12.01 .0030 13.02 .0042 14.00 .0021 15.01 .0049
+ 16.02 .0006 17.02 .0003 18.02 .0007 19.00 .0001 20.03 .0005 21.02 .0010 22.05 .0002 23.04 .0012
+ 24.05 .0003 25.02 .0002 26.03 .0003 27.02 .0004 28.03 .0001 29.05 .0002 30.05 .0001 33.03 .0001
+ 34.04 .0001 35.04 .0001 36.04 .0003 38.05 .0001 40.04 .0001))
+
+ (bc-ds3 '(1.01 .1501 2.00 .0036 3.00 .0682 4.00 .0069 4.99 .0142 5.98 .0017 6.99 .0322
+ 7.99 .0063 8.98 .0019 10.00 .0010 11.00 .0046 11.99 .0023 12.99 .0035 13.98 .0041 14.98 .0020
+ 15.97 .0001 16.98 .0003 17.98 .0008 18.98 .0009 20.03 .0002 21.00 .0007 21.99 .0006 22.99 .0006
+ 23.99 .0003 24.98 .0004 25.98 .0003 26.97 .0001 27.98 .0001 29.97 .0001 30.98 .0002 32.96 .0003
+ 33.97 .0003 34.95 .0002 35.96 .0002 36.97 .0001))
+
+ (bc-e3 '(.99 .1413 1.99 .0047 3.00 .0710 4.01 .0016 5.01 .0154 6.01 .0063 7.01 .0122
+ 8.02 .0179 9.00 .0044 10.00 .0082 11.01 .0058 12.01 .0031 13.02 .0045 14.02 .0027 15.02 .0004
+ 16.03 .0010 17.01 .0008 18.04 .0002 19.04 .0004 20.03 .0006 21.04 .0004 22.03 .0003 23.04 .0004
+ 24.04 .0002 25.04 .0003 26.06 .0001 27.04 .0003 28.03 .0002 29.02 .0003 30.99 .0002 32.04 .0006
+ 33.03 .0002 34.04 .0003 36.04 .0001))
+
+ (bc-f3 '(.99 .2534 1.99 .0057 3.00 .0476 3.98 .0101 4.98 .0334 5.97 .0066 6.98 .0489
+ 7.96 .0038 8.96 .0096 9.95 .0008 10.96 .0056 11.95 .0049 12.95 .0029 13.95 .0002 14.95 .0006
+ 15.96 .0002 16.96 .0008 17.94 .0004 18.93 .0002 19.94 .0009 20.94 .0002 21.93 .0004 22.94 .0004
+ 23.93 .0004 25.90 .0004 26.90 .0003 27.89 .0001 28.91 .0004 29.87 .0001 30.89 .0005 32.89 .0002
+ 33.87 .0001))
+
+ (bc-fs3 '(1.00 .3131 1.99 .0095 3.00 .0885 3.99 .0194 4.98 .0653 5.99 .0049 6.98 .0528
+ 7.99 .0038 8.98 .0129 9.97 .0042 10.98 .0063 11.97 .0023 12.97 .0016 13.98 .0002 14.97 .0004
+ 15.97 .0005 16.97 .0006 17.96 .0001 18.96 .0008 20.95 .0007 21.96 .0001 22.95 .0001 23.94 .0003
+ 25.94 .0004 26.95 .0004 27.94 .0005 28.93 .0003 29.94 .0003 31.93 .0002 33.92 .0002))
+
+ (bc-g3 '(1.00 .2177 2.01 .0024 3.01 .0126 4.02 .0067 5.02 .0577 6.02 .0083 7.02 .0215
+ 8.03 .0034 9.03 .0047 10.04 .0046 11.05 .0143 12.04 .0037 13.04 .0010 14.05 .0005 15.06 .0005
+ 16.06 .0003 17.06 .0002 18.06 .0004 19.09 .0001 20.08 .0003 21.08 .0002 23.08 .0003 24.08 .0003
+ 25.08 .0001 26.10 .0010 27.11 .0002 28.10 .0004 30.12 .0003 32.13 .0003))
+
+ (bc-gs3 '(1.01 .1420 2.01 .0026 3.01 .0289 4.03 .0162 5.03 .0373 6.02 .0015 7.03 .0112
+ 8.05 .0068 9.05 .0063 10.04 .0027 11.06 .0022 12.07 .0004 13.06 .0008 14.07 .0011 15.08 .0003
+ 16.08 .0002 17.09 .0005 19.11 .0003 23.12 .0004 24.12 .0003 25.14 .0002 26.14 .0003 27.14 .0002
+ 28.14 .0002 29.16 .0002 30.16 .0001 34.18 .0002))
+
+ (bc-a3 '(1.01 .2365 2.02 .0034 3.03 .0242 4.04 .0251 5.04 .0203 6.06 .0078 7.06 .0213
+ 8.08 .0162 9.09 .0121 10.10 .0053 11.11 .0024 12.12 .0028 13.14 .0010 14.13 .0006 15.15 .0009
+ 16.16 .0008 17.17 .0009 18.18 .0006 19.19 .0003 20.20 .0003 21.20 .0003 22.22 .0004 23.22 .0002
+ 24.24 .0007 26.26 .0003 27.26 .0001 29.29 .0003))
+
+ (bc-as3 '(1.00 .1078 2.01 .0072 3.02 .0487 4.04 .0332 5.05 .0329 6.06 .0069 7.07 .0153
+ 8.08 .0061 9.08 .0082 10.09 .0023 11.10 .0003 12.11 .0009 13.12 .0008 14.13 .0007 15.15 .0003
+ 16.16 .0006 17.16 .0007 18.16 .0003 19.17 .0003 20.18 .0005 21.19 .0005 22.20 .0005 23.22 .0004
+ 24.23 .0001 26.25 .0001 27.25 .0001 28.26 .0001))
+
+ (bc-b3 '(1.01 .0572 2.02 .0086 3.03 .0724 4.04 .0057 5.04 .0365 6.05 .0058 7.06 .0083
+ 8.07 .0113 9.08 .0102 10.09 .0022 11.10 .0012 12.11 .0005 13.11 .0014 14.12 .0003 15.13 .0008
+ 16.14 .0009 17.15 .0003 18.16 .0002 19.17 .0006 20.18 .0009 21.19 .0002 22.19 .0006 23.20 .0004
+ 24.21 .0004 25.22 .0001))
+
+ (bc-c4 '(1.01 .0509 2.02 .0146 3.02 .0344 4.03 .0126 5.04 .0254 6.05 .0004 7.05 .0134
+ 8.06 .0069 9.08 .0007 10.09 .0005 11.09 .0006 12.09 .0004 13.11 .0010 14.12 .0001 15.12 .0008
+ 16.13 .0001 17.14 .0003 18.15 .0002 19.17 .0001 20.16 .0004 21.17 .0002))
+
+ (bc-cs4 '(1.00 .1853 2.00 .0169 3.01 .0922 4.01 .0035 5.01 .0204 6.01 .0046 7.02 .0077
+ 8.02 .0085 9.02 .0028 10.05 .0002 11.02 .0003 12.03 .0006 13.05 .0002 14.03 .0006 15.04 .0006
+ 16.04 .0004 17.02 .0003 18.04 .0006 19.04 .0004 20.04 .0003 21.06 .0001 22.04 .0001 23.06 .0002))
+
+ (bc-d4 '(1.00 .3391 2.00 .0134 2.99 .0186 3.99 .0424 4.98 .0122 5.98 .0055 6.97 .0197
+ 7.98 .0034 8.97 .0017 9.98 .0004 10.96 .0008 11.96 .0009 12.96 .0003 13.96 .0007 14.95 .0004
+ 15.94 .0002 16.95 .0003 17.94 .0008 18.93 .0002 19.93 .0001))
+
+ (bc-ds4 '(.99 .3684 1.98 .0187 2.98 .0647 3.97 .0186 4.97 .0070 5.96 .0127 6.95 .0173
+ 7.94 .0011 8.94 .0011 9.93 .0014 10.92 .0013 11.90 .0001 12.90 .0006 13.91 .0003 14.89 .0003
+ 15.89 .0001 16.88 .0010 17.88 .0004 18.86 .0001 19.86 .0002 20.85 .0001))
+
+ (bc-e4 '(1.00 .5390 3.01 .0188 4.00 .0247 5.00 .0129 6.01 .0050 7.01 .0014 8.01 .0012
+ 9.01 .0012 10.01 .0010 11.02 .0005 12.02 .0002 13.03 .0004))
+
+ (bc-f4 '(1.01 .5398 2.01 .0309 3.01 .0727 4.01 .0062 5.01 .0041 6.02 .0280 7.02 .0005
+ 8.02 .0014 9.02 .0013 10.02 .0030 11.03 .0006 12.03 .0004 14.03 .0003 15.04 .0003 16.04 .0007))
+
+ (bc-fs4 '(1.00 .6398 2.01 .0314 3.01 .0423 4.01 .0292 5.01 .0093 6.02 .0088 7.02 .0010
+ 8.03 .0043 9.02 .0004 10.03 .0013 11.03 .0003 12.04 .0003 13.02 .0002 14.04 .0010 15.04 .0006
+ 16.05 .0001 17.04 .0003))
+
+ (bc-g4 '(1.00 .5985 1.99 .0192 2.99 .0346 3.99 .0257 4.98 .0082 5.98 .0037 6.98 .0008
+ 7.99 .0013 8.97 .0014 9.98 .0016 10.98 .0010 11.98 .0005 12.97 .0005 13.97 .0008 14.95 .0002
+ 15.96 .0003))
+
+ (bc-gs4 '(1.00 .2635 1.99 .0230 2.99 .0936 3.99 .0214 4.99 .0320 5.99 .0013 6.99 .0020
+ 7.99 .0004 8.99 .0014 9.99 .0003 10.99 .0003 11.98 .0005 12.98 .0015 13.98 .0005 14.98 .0003
+ 15.98 .0003 18.98 .0001))
+
+ (bc-a4 '(1.00 .1539 2.00 .0355 3.00 .0834 4.01 .0210 5.01 .0103 6.00 .0035 7.02 .0004
+ 8.01 .0008 9.00 .0002 10.01 .0001 11.01 .0005 12.01 .0007 13.02 .0011 14.01 .0003 15.02 .0003
+ 18.02 .0002))
+
+ (bc-as4 '(1.00 .1843 2.01 .0229 3.00 .0348 4.01 .0157 5.01 .0170 6.01 .0037 7.02 .0012
+ 8.02 .0027 9.02 .0003 10.02 .0011 11.03 .0010 12.03 .0007 13.03 .0004 14.03 .0002 15.03 .0002
+ 17.04 .0002))
+
+ (bc-b4 '(1.00 .5063 2.01 .0563 3.01 .0376 4.01 .0383 5.01 .0135 6.02 .0081 7.02 .0011
+ 8.02 .0049 9.03 .0007 10.03 .0006 11.04 .0013 12.04 .0007 13.04 .0004 14.05 .0002 15.05 .0002
+ 17.05 .0002 19.06 .0001))
+
+ (bc-c5 '(1.00 .5459 2.00 .0278 3.01 .0456 4.01 .0648 5.02 .0035 6.02 .0050 7.02 .0025
+ 8.02 .0021 9.02 .0005 10.03 .0007 11.03 .0016 12.03 .0007 13.04 .0001 14.03 .0002 15.04 .0002
+ 18.05 .0002 19.05 .0001 20.05 .0002))
+
+ (bc-cs5 '(1.00 .2584 2.01 .0583 3.02 .1090 4.02 .0290 5.02 .0020 6.03 .0018 7.03 .0016
+ 8.03 .0001 9.04 .0005 10.05 .0017 11.05 .0010 12.05 .0002 13.06 .0001 14.06 .0001 17.08 .0002
+ 18.08 .0001 19.08 .0001))
+
+ (bc-d5 '(1.00 .1626 2.00 .0485 3.01 .0856 4.00 .0023 5.01 .0096 6.01 .0042 7.01 .0015
+ 8.01 .0004 9.02 .0019 10.02 .0016 11.02 .0003 12.02 .0002 13.02 .0002 16.03 .0001 17.03 .0001
+ 18.03 .0002 19.03 .0001))
+
+ (bc-ds5 '(1.00 .1756 1.99 .1645 2.99 .0381 3.98 .0028 4.98 .0042 5.98 .0004 6.97 .0025
+ 7.97 .0006 8.96 .0022 9.96 .0011 10.96 .0002 13.94 .0002 14.94 .0002 15.94 .0001 16.93 .0001
+ 17.93 .0001))
+
+ (bc-e5 '(.99 .2661 1.99 .1398 2.99 .0589 3.99 .0048 4.98 .0022 5.98 .0015 6.97 .0021
+ 7.97 .0008 8.96 .0011 9.96 .0009 10.95 .0004 11.94 .0001 13.94 .0001 14.94 .0001 15.94 .0001))
+
+ (bc-f5 '(1.00 .1378 2.00 .0654 3.00 .1301 4.00 .0049 5.00 .0030 6.01 .0018 7.01 .0030
+ 8.01 .0015 9.01 .0008 10.01 .0001 11.01 .0003 12.01 .0002 13.01 .0001 14.01 .0002 15.01 .0002
+ 16.02 .0001))
+
+ (bc-fs5 '(1.00 .3952 2.01 .1124 3.01 .0326 4.02 .0104 5.03 .0013 6.03 .0010 7.03 .0009
+ 8.04 .0009 9.05 .0002 10.05 .0003 11.05 .0001 13.06 .0002 14.07 .0003 15.08 .0002))
+
+ (bc-g5 '(1.01 .3434 2.01 .0390 3.02 .0051 4.03 .0057 5.04 .0042 6.05 .0017 7.06 .0022
+ 8.06 .0012 9.07 .0002 10.07 .0001 11.08 .0002 12.09 .0002 13.10 .0002 14.11 .0002 15.12 .0001))
+
+ (bc-gs5 '(1.00 .1109 1.99 .0911 2.98 .0061 3.98 .0062 4.98 .0020 5.97 .0006 6.96 .0008
+ 7.96 .0013 8.95 .0002 10.94 .0002 11.94 .0002 12.93 .0002 13.93 .0001))
+
+ (bc-a5 '(1.00 .1585 2.00 .0562 3.00 .0039 4.00 .0064 5.00 .0016 6.00 .0022 7.00 .0009
+ 8.00 .0004 9.00 .0002 11.00 .0003 12.00 .0003 13.00 .0002 14.00 .0002))
+
+ (bc-as5 '(.99 .1211 1.98 .0394 2.97 .0093 3.96 .0024 4.95 .0030 5.94 .0027 6.93 .0006
+ 8.92 .0002 10.90 .0001 12.88 .0001))
+
+
+ ;; bassoon?
+ (bsn-as1 '(1.00 .0038 2.02 .0235 3.04 .0511 4.06 .0348 5.07 .0491 6.09 .0518 7.11 .0184
+ 8.12 .0381 9.11 .1027 10.13 .0412 11.15 .0112 12.17 .0144 13.18 .0097 14.20 .0074 15.21 .0081
+ 16.23 .0067 17.22 .0108 18.24 .0113 19.25 .0114 20.28 .0066 21.30 .0065 22.32 .0035 23.33 .0041
+ 24.33 .0036 25.34 .0025 26.35 .0010 27.37 .0021 28.39 .0007 29.42 .0006 30.42 .0009 31.43 .0005
+ 32.43 .0003 33.46 .0005 34.46 .0002 35.48 .0002 36.48 .0004 37.52 .0003 38.53 .0003 39.55 .0002
+ 40.56 .0002 51.69 .0001 54.72 .0002))
+
+ (bsn-b1 '(1.01 .0039 2.02 .0230 3.02 .0517 4.03 .0473 5.03 .0443 6.03 .0691 7.03 .0664
+ 8.04 .0408 9.04 .1283 10.06 .0429 11.07 .0339 12.08 .0223 13.08 .0207 14.08 .0256 15.08 .0171
+ 16.09 .0106 17.09 .0136 18.09 .0082 19.12 .0052 20.12 .0041 21.13 .0015 22.13 .0023 23.12 .0021
+ 24.12 .0009 25.13 .0029 26.14 .0014 27.15 .0003 28.15 .0010 29.17 .0013 30.18 .0003 31.19 .0005
+ 32.19 .0007 33.19 .0004 34.20 .0005 35.19 .0005 36.19 .0003 37.21 .0003 38.23 .0002 39.23 .0001
+ 40.23 .0001 43.23 .0001 46.26 .0002 49.27 .0002 51.27 .0003 52.27 .0002 53.28 .0002))
+
+ (bsn-c2 '(1.01 .0047 2.03 .0390 3.04 .0460 4.04 .0217 5.05 .0464 6.05 .0631 7.06 .0874
+ 8.07 .1167 9.08 .0339 10.09 .0209 11.11 .0133 12.12 .0088 13.11 .0092 14.14 .0032 15.15 .0026
+ 16.16 .0061 17.17 .0019 18.17 .0051 19.18 .0161 20.18 .0048 21.20 .0044 22.21 .0035 23.23 .0010
+ 24.24 .0028 25.25 .0006 26.26 .0013 27.27 .0016 28.26 .0002 29.28 .0006 30.28 .0006 31.30 .0004
+ 32.32 .0012 33.33 .0003 34.34 .0003 35.35 .0002 36.34 .0001 43.41 .0001 46.43 .0001 48.44 .0001
+ 51.48 .0001))
+
+ (bsn-cs2 '(1.01 .0090 2.02 .0531 3.01 .0318 4.01 .0199 5.02 .0211 6.04 .0629 7.04 .1340
+ 8.05 .0925 9.04 .0206 10.04 .0584 11.05 .0140 12.07 .0066 13.08 .0068 14.08 .0011 15.07 .0028
+ 16.07 .0015 17.08 .0041 18.10 .0106 19.10 .0034 20.10 .0033 21.10 .0020 22.10 .0021 23.11 .0040
+ 24.13 .0001 25.12 .0004 26.13 .0003 28.13 .0004 29.14 .0002 30.16 .0001 31.17 .0001 43.20 .0001
+ 46.22 .0002))
+
+ (bsn-d2 '(1.01 .0616 2.00 .0436 3.00 .0430 3.99 .0491 5.01 .0358 6.01 .1695 7.00 .1562
+ 7.99 .0174 8.99 .0062 10.01 .0054 11.00 .0104 12.00 .0055 12.99 .0052 13.99 .0018 15.00 .0021
+ 16.00 .0019 16.99 .0087 17.98 .0025 18.99 .0027 20.00 .0015 21.00 .0024 21.98 .0015 22.99 .0002
+ 24.00 .0006 25.99 .0001 26.95 .0001 28.00 .0001 28.94 .0001 30.01 .0002))
+
+ (bsn-ds2 '(1.01 .0769 2.01 .0341 3.00 .0240 4.00 .0633 5.00 .0124 5.99 .0850 6.99 .1044
+ 7.99 .0115 8.99 .0046 10.00 .0048 11.00 .0054 12.00 .0082 13.00 .0033 14.00 .0080 15.00 .0022
+ 15.99 .0081 16.99 .0028 17.98 .0038 18.98 .0028 19.99 .0032 20.99 .0007 22.00 .0003 22.98 .0004
+ 23.99 .0001 24.98 .0005 25.98 .0002 26.97 .0003 28.98 .0001 38.97 .0001 40.97 .0001))
+
+ (bsn-e2 '(1.00 .0369 1.98 .0190 3.00 .0291 3.98 .0844 5.00 .0730 5.98 .0856 7.00 .0563
+ 7.98 .0792 9.00 .0139 9.97 .0127 10.99 .0046 11.96 .0052 12.99 .0043 13.97 .0030 14.99 .0102
+ 15.98 .0020 16.97 .0029 17.98 .0010 18.96 .0040 19.98 .0008 20.97 .0004 21.99 .0001 23.98 .0004
+ 25.96 .0002 26.93 .0001 36.94 .0001))
+
+ (bsn-f2 '(.99 .0208 2.00 .0164 3.01 .0576 4.02 .0547 5.02 .0965 5.99 .1701 7.00 .0206
+ 8.01 .0040 9.02 .0075 10.02 .0033 11.00 .0067 12.00 .0021 13.01 .0010 14.02 .0072 15.03 .0014
+ 16.01 .0028 17.01 .0034 18.02 .0026 19.03 .0007 20.05 .0004 20.43 .0001 22.02 .0001 24.01 .0003
+ 26.03 .0001))
+
+ (bsn-fs2 '(1.00 .0112 1.99 .0211 2.98 .0379 3.97 .0630 4.98 .0727 5.97 .1555 6.95 .0348
+ 7.94 .0362 8.96 .0083 9.94 .0145 10.92 .0070 11.91 .0031 12.93 .0059 13.92 .0054 14.91 .0024
+ 15.89 .0024 16.88 .0045 17.90 .0013 18.91 .0007 19.87 .0005 20.87 .0004 21.88 .0002 22.85 .0007
+ 23.84 .0003 24.83 .0002 26.84 .0001 28.80 .0002 29.80 .0001 30.81 .0003 31.81 .0001 32.78 .0003
+ 33.77 .0001 34.79 .0002))
+
+ (bsn-g2 '(.98 .0330 1.99 .0314 2.95 .0487 3.95 .0272 4.95 .2864 5.91 .0849 6.92 .0047
+ 7.89 .0049 8.88 .0015 9.88 .0060 10.85 .0051 11.85 .0013 12.83 .0083 13.82 .0018 14.82 .0010
+ 15.78 .0032 16.79 .0007 17.77 .0004 18.76 .0005 19.76 .0008 20.72 .0004 21.72 .0009 22.72 .0003
+ 23.69 .0002))
+
+ (bsn-gs2 '(.98 .0321 1.98 .0281 2.99 .0196 3.99 .0683 4.96 .2698 5.95 .0125 6.95 .0153
+ 7.96 .0034 8.96 .0050 9.93 .0056 10.92 .0049 11.92 .0160 12.92 .0072 13.91 .0013 14.89 .0028
+ 15.91 .0005 16.86 .0004 17.89 .0006 18.89 .0009 19.87 .0005 20.85 .0001 21.87 .0003 27.83 .0001
+ 28.82 .0002))
+
+ (bsn-a2 '(.99 .0170 2.00 .0296 3.00 .0324 4.01 .1542 5.02 .1393 6.02 .0249 7.03 .0041
+ 8.03 .0022 9.01 .0043 10.02 .0077 11.03 .0092 12.04 .0021 13.04 .0027 14.05 .0026 15.06 .0007
+ 16.05 .0001 17.05 .0003 18.04 .0006 19.04 .0004 20.05 .0002 26.06 .0003 27.06 .0002 29.07 .0001))
+
+ (bsn-as2 '(1.01 .0153 2.00 .0261 3.00 .0305 3.99 .1573 4.97 .0908 5.98 .0053 6.97 .0054
+ 7.98 .0159 8.99 .0031 9.99 .0015 10.96 .0124 11.96 .0020 12.95 .0026 13.94 .0034 14.94 .0005
+ 16.95 .0007 17.93 .0002 18.94 .0003 24.92 .0002 25.91 .0002 27.89 .0002 28.89 .0001))
+
+ (bsn-b2 '(1.01 .0061 2.00 .0199 2.99 .0393 3.98 .2060 5.00 .0178 5.99 .0340 6.98 .0029
+ 7.98 .0065 8.99 .0102 9.99 .0271 10.98 .0068 11.97 .0032 12.97 .0060 13.99 .0002 14.98 .0005
+ 15.96 .0008 16.96 .0008 17.98 .0006 18.98 .0001 21.96 .0001 22.96 .0002 23.95 .0002 24.94 .0002
+ 25.94 .0001 26.95 .0001 28.95 .0001))
+
+ (bsn-c3 '(1.00 .0082 1.98 .0489 2.99 .1248 3.98 .1892 4.97 .0149 5.98 .0017 6.96 .0172
+ 7.95 .0072 8.96 .0028 9.95 .0114 10.93 .0055 11.94 .0029 12.96 .0005 13.92 .0017 14.93 .0008
+ 15.91 .0012 16.90 .0005 17.91 .0001 20.90 .0001 21.88 .0003 22.87 .0001 24.85 .0002 28.85 .0001))
+
+ (bsn-cs3 '(1.01 .0191 2.00 .0451 2.99 .2847 4.00 .0925 5.00 .0143 5.99 .0024 7.00 .0055
+ 8.00 .0131 8.99 .0286 9.98 .0021 10.99 .0020 11.99 .0010 12.96 .0003 13.97 .0005 14.98 .0009
+ 15.97 .0005 20.97 .0003 21.97 .0003))
+
+ (bsn-d3 '(1.01 .0218 2.01 .0560 3.01 .1696 4.01 .0504 5.00 .0268 6.02 .0018 7.03 .0081
+ 8.03 .0035 9.04 .0026 10.04 .0023 11.02 .0045 12.04 .0002 13.04 .0004 14.04 .0007 15.05 .0004
+ 16.06 .0001 21.06 .0001 22.07 .0003))
+
+ (bsn-ds3 '(1.00 .0185 1.99 .0627 2.98 .2037 3.97 .0211 4.98 .0204 5.97 .0434 6.95 .0056
+ 7.94 .0171 8.95 .0014 9.94 .0062 10.93 .0007 11.91 .0006 12.91 .0004 13.90 .0004 14.90 .0003
+ 16.88 .0001 17.89 .0002 18.88 .0002 20.86 .0004 21.84 .0002 22.85 .0001))
+
+ (bsn-e3 '(1.00 .0167 2.00 .0801 3.01 .2223 4.02 .0252 5.02 .0098 6.01 .0058 7.02 .0073
+ 8.03 .0032 9.03 .0066 10.04 .0011 10.66 .0001 12.04 .0013 13.04 .0013 14.05 .0010 15.05 .0004
+ 18.07 .0002 20.06 .0003 23.07 .0001))
+
+ (bsn-f3 '(1.00 .0152 2.01 .0471 3.00 .1985 4.00 .0345 5.01 .0136 6.00 .0064 7.01 .0153
+ 8.00 .0011 9.00 .0093 10.02 .0006 11.01 .0006 12.00 .0001 13.01 .0008 14.01 .0006 16.02 .0001
+ 17.01 .0003 19.01 .0002 22.01 .0001 23.02 .0002))
+
+ (bsn-fs3 '(1.01 .0363 2.01 .1019 3.01 .3226 4.01 .1274 5.03 .0397 6.03 .0061 7.02 .0117
+ 8.03 .0099 9.04 .0006 10.04 .0026 11.04 .0020 12.04 .0008 13.05 .0001 14.06 .0002 15.05 .0002
+ 19.07 .0002))
+
+ (bsn-g3 '(.99 .0358 1.99 .0535 2.99 .1072 3.99 .0270 4.99 .0106 5.98 .0010 6.97 .0007
+ 7.97 .0041 8.95 .0002 9.94 .0002 10.97 .0002 12.96 .0001))
+
+ (bsn-gs3 '(1.00 .0382 1.99 .0923 2.99 .0199 3.99 .0156 4.96 .0044 5.98 .0130 6.97 .0020
+ 7.97 .0033 8.97 .0007 9.95 .0002 10.95 .0001 12.95 .0001))
+
+ (bsn-a3 '(1.00 .0469 2.00 .2187 3.00 .0287 4.01 .0121 5.01 .0114 6.01 .0022 7.01 .0044
+ 8.02 .0008 9.02 .0004 10.01 .0003 13.02 .0001))
+
+ (bsn-as3 '(1.01 .0298 2.01 .2016 3.02 .0058 4.00 .0258 5.00 .0008 6.00 .0029 7.00 .0031
+ 8.01 .0010 9.01 .0004 10.00 .0001 13.01 .0001))
+
+ (bsn-b3 '(1.01 .0341 2.01 .2100 3.01 .0390 4.02 .0044 5.02 .0213 6.02 .0044 7.02 .0006
+ 8.03 .0012 9.04 .0002 12.05 .0002 13.05 .0002))
+
+ (bsn-c4 '(1.00 .0684 2.00 .2934 3.00 .0096 4.00 .0084 5.00 .0039 6.00 .0059 7.00 .0010
+ 8.00 .0006))
+
+ (bsn-cs4 '(1.01 .0848 2.01 .3334 3.02 .0152 4.03 .0032 5.03 .0059 6.03 .0032 7.05 .0013
+ 8.05 .0007 9.05 .0001 10.06 .0001 11.06 .0002))
+
+ (bsn-d4 '(1.00 .1020 2.00 .1065 3.00 .0086 3.99 .0013 5.00 .0038 6.00 .0011 7.00 .0003
+ 8.00 .0002 11.01 .0003))
+
+ (bsn-ds4 '(1.00 .0469 1.99 .0248 2.96 .0045 3.99 .0163 4.99 .0042 6.00 .0004 6.98 .0003))
+
+ (bsn-e4 '(1.00 .0389 2.01 .0439 3.01 .0110 4.01 .0072 5.02 .0041 6.02 .0005 7.02 .0006
+ 9.03 .0003))
+
+ (bsn-f4 '(1.00 .0229 2.00 .0331 2.99 .0138 4.00 .0008 4.99 .0010 5.99 .0004))
+
+ (bsn-fs4 '(1.00 .1522 1.99 .0563 3.00 .0126 3.99 .0035 4.28 .0002 4.35 .0002 4.43 .0001
+ 4.98 .0001 5.99 .0001 6.98 .0002))
+
+ (bsn-g4 '(1.00 .0415 2.00 .0486 3.00 .0068 4.00 .0148 5.00 .0016 6.00 .0001))
+
+ (bsn-gs4 '(1.01 .0811 2.01 .0402 3.03 .0114 4.04 .0044 5.03 .0004))
+
+ (bsn-a4 '(1.00 .0399 2.01 .0195 3.00 .0069 4.01 .0005 5.01 .0009 6.01 .0002 7.01 .0003))
+
+ (bsn-as4 '(1.01 .1259 2.01 .0811 3.01 .0051 4.01 .0027 5.01 .0008 6.02 .0002 7.02 .0003))
+
+ (bsn-b4 '(1.01 .1159 2.02 .0380 3.03 .0089 4.04 .0038 5.05 .0006 6.05 .0002))
+
+ (bsn-c5 '(1.02 .0871 2.03 .0356 3.04 .0192 4.06 .0063 6.09 .0003 7.11 .0002))
+
+ (bsn-cs5 '(1.01 .2418 2.02 .0674 3.02 .0067 4.03 .0021 5.03 .0004 6.05 .0003 7.05 .0005
+ 8.06 .0001))
+
+ (bsn-d5 '(1.01 .1931 2.01 .0462 3.02 .0118 4.02 .0014 5.03 .0006 6.03 .0008 8.04 .0001))
+
+
+ ;; cello
+ (c-c2 '(1.00 .0047 1.99 .0251 2.99 .0546 4.01 .1041 4.99 .0279 5.97 .0219 6.93 .0137
+ 7.94 .0349 8.91 .0151 10.04 .0565 11.00 .0458 12.00 .0216 12.97 .0151 14.52 .0025 14.95 .0088
+ 16.03 .0103 17.02 .0027 17.98 .0089 19.00 .0052 20.03 .0048 20.93 .0051 22.04 .0023 23.01 .0072
+ 24.01 .0022 24.99 .0027 26.03 .0036 27.47 .0011 27.99 .0011 29.02 .0012 29.86 .0005 30.97 .0020
+ 31.88 .0006 33.02 .0021 33.98 .0011 35.02 .0010 36.01 .0028 37.00 .0022 37.99 .0014 39.00 .0014
+ 40.01 .0022 41.04 .0021 42.02 .0008 43.01 .0024 44.02 .0007 45.01 .0003 46.00 .0002 48.03 .0002
+ 48.85 .0002 51.01 .0001 51.98 .0001 54.89 .0002 55.39 .0002 56.38 .0001 58.02 .0002 58.98 .0002
+ 62.00 .0001 64.09 .0001 65.02 .0002))
+
+ (c-cs2 '(1.01 .0160 2.02 .0737 3.02 .0287 4.02 .0183 5.02 .0669 6.04 .0520 7.05 .0043
+ 8.06 .0066 9.06 .0194 10.05 .0193 11.05 .0254 12.06 .0153 13.08 .0041 14.11 .0037 15.09 .0098
+ 16.09 .0022 17.09 .0053 18.10 .0135 19.12 .0118 20.13 .0057 21.15 .0039 22.14 .0023 23.14 .0027
+ 24.15 .0026 25.16 .0012 26.16 .0011 27.17 .0020 28.17 .0015 29.14 .0020 30.19 .0013 31.19 .0019
+ 32.20 .0007 33.21 .0005 34.22 .0004 35.19 .0012 36.20 .0005 37.25 .0015 38.25 .0018 39.26 .0014
+ 40.40 .0007 41.25 .0010 42.24 .0009 43.28 .0003 44.31 .0002 45.28 .0002 46.30 .0001 48.29 .0002
+ 49.31 .0004 50.34 .0001 51.35 .0002 52.32 .0003 53.50 .0001 54.28 .0001 57.34 .0001 58.35 .0002))
+
+ (c-d2 '(1.00 .0368 2.02 .1070 3.03 .0107 4.04 .0445 5.04 .0477 6.04 .0281 7.07 .0191
+ 8.06 .0205 9.06 .0456 10.07 .0283 11.07 .0320 12.08 .0094 13.35 .0009 14.11 .0042 15.11 .0066
+ 16.12 .0075 17.13 .0117 18.14 .0043 19.16 .0067 20.14 .0020 21.16 .0046 22.16 .0011 23.17 .0029
+ 24.17 .0010 25.18 .0011 26.19 .0013 27.18 .0029 28.20 .0039 29.21 .0048 30.23 .0020 31.23 .0006
+ 32.25 .0018 33.23 .0009 34.24 .0012 35.28 .0016 36.27 .0018 37.28 .0019 38.28 .0031 39.28 .0008
+ 40.25 .0001 41.30 .0002 42.31 .0002 43.32 .0001 44.32 .0002 45.33 .0002 46.34 .0004 48.37 .0002
+ 49.37 .0006 50.37 .0004 51.35 .0001 52.35 .0001 53.40 .0001 54.39 .0002 55.41 .0003 56.43 .0002
+ 57.41 .0001 64.49 .0001 65.50 .0001))
+
+ (c-ds2 '(1.01 .0485 2.01 .1800 3.01 .0143 4.02 .1265 5.03 .1372 6.03 .0102 7.02 .0261
+ 8.03 .0216 9.02 .0145 10.04 .0292 11.05 .0133 12.06 .0038 13.06 .0026 14.04 .0041 15.06 .0053
+ 16.06 .0014 17.08 .0051 18.06 .0048 19.07 .0026 20.07 .0025 21.09 .0039 22.08 .0018 23.08 .0031
+ 24.11 .0023 25.10 .0035 26.10 .0037 27.10 .0019 28.10 .0030 29.11 .0020 30.10 .0036 31.13 .0020
+ 32.10 .0011 33.13 .0013 34.12 .0027 35.11 .0022 36.13 .0018 37.15 .0005 38.13 .0002 39.17 .0002
+ 40.16 .0006 41.13 .0002 43.16 .0002 44.16 .0002 45.15 .0002 46.18 .0003 47.17 .0001 48.18 .0001
+ 49.16 .0002 50.19 .0001 58.35 .0001))
+
+ (c-e2 '(1.02 .0293 2.00 .1425 3.04 .0549 4.03 .0364 5.03 .1171 6.07 .0100 7.04 .0253
+ 8.06 .0448 9.08 .0115 10.06 .0116 11.08 .0048 12.09 .0174 13.09 .0037 14.11 .0029 15.11 .0104
+ 16.12 .0036 17.14 .0046 18.13 .0016 19.16 .0027 20.13 .0036 21.14 .0012 22.18 .0027 23.17 .0011
+ 24.18 .0033 25.20 .0019 26.20 .0016 26.99 .0005 28.22 .0009 29.19 .0052 30.23 .0021 31.21 .0015
+ 32.24 .0014 33.23 .0019 34.22 .0033 35.27 .0009 36.27 .0002 38.30 .0004 39.27 .0005 40.26 .0004
+ 41.25 .0003 42.31 .0002 43.34 .0007 44.32 .0006 45.32 .0003 46.36 .0002 47.36 .0001 48.34 .0002
+ 49.37 .0002 54.40 .0002 55.40 .0001))
+
+ (c-f2 '(.99 .0765 2.00 .0311 3.02 .0635 4.02 .0223 5.15 .0022 6.01 .0457 7.03 .0278
+ 8.04 .0188 9.04 .0344 10.02 .0093 11.00 .0034 12.05 .0172 13.06 .0106 14.07 .0020 15.02 .0011
+ 16.06 .0022 17.08 .0027 18.08 .0007 19.05 .0016 20.07 .0015 21.07 .0057 22.10 .0010 23.07 .0030
+ 24.07 .0013 25.07 .0019 26.09 .0018 27.10 .0042 28.10 .0020 29.09 .0015 30.12 .0027 31.11 .0021
+ 32.13 .0035 33.08 .0003 34.12 .0005 35.12 .0004 36.15 .0008 37.15 .0003 39.14 .0005 40.17 .0003
+ 41.15 .0003 42.14 .0002 43.14 .0001 44.17 .0002 51.84 .0001 53.18 .0001 54.22 .0001))
+
+ (c-fs2 '(1.02 .0680 2.02 .0790 3.03 .0722 4.03 .0851 5.03 .0169 6.03 .0073 7.02 .0859
+ 8.02 .0250 9.04 .0073 10.07 .0037 11.04 .0035 12.01 .0009 13.09 .0056 14.05 .0059 15.05 .0031
+ 16.07 .0050 17.07 .0034 18.07 .0010 19.47 .0004 20.10 .0045 21.10 .0028 22.09 .0039 23.10 .0032
+ 24.11 .0007 25.09 .0017 26.10 .0041 27.16 .0006 28.12 .0021 29.13 .0021 30.39 .0004 31.11 .0013
+ 32.17 .0004 33.13 .0005 34.14 .0014 35.07 .0002 36.06 .0001 37.16 .0002 39.18 .0007 40.18 .0002
+ 41.22 .0001 42.21 .0002 43.24 .0003 49.15 .0001 51.22 .0001 52.23 .0002))
+
+ (c-g2 '(1.00 .0434 2.00 .0983 2.99 .0548 3.98 .0364 4.98 .0228 5.97 .0390 6.97 .0091
+ 7.96 .0154 9.03 .0078 9.96 .0174 10.98 .0110 11.96 .0125 12.97 .0039 13.94 .0028 14.95 .0057
+ 15.94 .0020 16.95 .0046 17.94 .0011 18.97 .0017 19.94 .0010 20.98 .0025 21.94 .0040 22.94 .0030
+ 23.91 .0064 24.95 .0013 25.96 .0009 26.94 .0015 27.92 .0014 28.93 .0017 29.91 .0015 30.92 .0010
+ 31.49 .0002 32.83 .0002 33.89 .0003 34.92 .0002 36.91 .0003 37.91 .0002 40.84 .0002 41.87 .0002
+ 42.89 .0002))
+
+ (c-gs2 '(.98 .0579 1.97 .0445 2.97 .1178 3.97 .0806 4.96 .1095 5.94 .0245 6.92 .0203
+ 7.91 .0153 8.92 .0186 9.93 .0129 10.92 .0154 11.89 .0040 12.87 .0036 13.88 .0033 14.74 .0006
+ 15.85 .0011 16.86 .0020 17.85 .0026 18.84 .0040 19.84 .0022 20.83 .0022 21.82 .0020 22.80 .0060
+ 23.79 .0073 24.81 .0023 25.80 .0030 26.79 .0008 27.77 .0005 28.75 .0012 29.73 .0017 30.75 .0003
+ 31.74 .0005 32.74 .0003 33.71 .0003 34.70 .0005 35.72 .0002 36.67 .0003 38.69 .0002 39.71 .0002
+ 40.65 .0001))
+
+ (c-a2 '(.99 .0612 1.98 .0094 2.98 .0435 3.98 .0098 4.97 .0550 5.97 .0775 6.96 .0337
+ 7.96 .0330 8.97 .0137 9.95 .0122 10.95 .0080 11.94 .0082 13.00 .0009 13.95 .0034 14.96 .0029
+ 15.94 .0011 16.94 .0041 17.95 .0060 18.92 .0008 19.97 .0026 20.94 .0009 21.94 .0041 22.92 .0050
+ 23.92 .0056 24.93 .0030 25.92 .0015 26.22 .0002 27.90 .0011 28.90 .0004 29.89 .0007 30.89 .0009
+ 31.90 .0004 32.91 .0002 33.88 .0005 34.86 .0001 35.89 .0003 36.87 .0006 37.89 .0003 38.93 .0002
+ 46.84 .0001 54.82 .0001))
+
+ (c-as2 '(1.00 .0401 1.99 .0101 2.98 .0769 3.96 .0345 4.96 .0696 5.97 .0342 6.95 .0413
+ 7.95 .0130 8.92 .0147 9.93 .0034 10.94 .0135 11.94 .0007 12.92 .0013 13.91 .0017 14.89 .0026
+ 15.88 .0019 16.89 .0039 17.88 .0034 18.86 .0037 19.84 .0009 20.85 .0021 21.86 .0021 22.85 .0049
+ 23.82 .0042 24.82 .0007 25.80 .0007 26.82 .0003 27.81 .0004 28.79 .0009 29.79 .0007 30.77 .0005
+ 31.18 .0001 31.66 .0001 32.76 .0002 33.78 .0002 34.76 .0004 35.75 .0002 36.74 .0002))
+
+ (c-b2 '(1.00 .0486 1.99 .0621 2.98 .0627 3.98 .0145 4.98 .0494 5.97 .0353 6.96 .0287
+ 7.96 .0169 8.95 .0167 9.95 .0039 10.94 .0075 11.94 .0043 12.95 .0018 13.92 .0040 14.94 .0054
+ 15.93 .0046 16.93 .0035 17.92 .0037 18.93 .0036 19.91 .0055 20.89 .0055 21.89 .0058 22.89 .0039
+ 23.88 .0005 24.87 .0009 25.87 .0003 26.87 .0007 27.78 .0002 28.86 .0004 29.86 .0004 30.85 .0004
+ 31.86 .0001 32.83 .0009 33.83 .0003 34.82 .0001 37.81 .0002 43.79 .0001 48.71 .0001))
+
+ (c-c3 '(.99 .0486 1.98 .1268 2.99 .0920 3.98 .0752 4.96 .1515 5.95 .0086 6.97 .0102
+ 7.95 .0108 8.95 .0120 9.94 .0034 10.95 .0029 11.94 .0007 12.91 .0029 13.92 .0077 14.90 .0028
+ 15.89 .0027 16.90 .0038 17.92 .0034 18.87 .0115 19.89 .0039 20.89 .0023 21.86 .0023 22.88 .0008
+ 23.88 .0006 24.86 .0004 26.05 .0002 26.84 .0003 27.84 .0005 28.84 .0003 29.80 .0004 30.82 .0007
+ 31.58 .0001 31.79 .0001 32.52 .0001 33.80 .0001 34.80 .0001 39.78 .0002))
+
+ (c-cs3 '(1.01 .0839 1.99 .0414 2.99 .1265 4.00 .0196 5.00 .0377 6.00 .0117 6.99 .0111
+ 8.00 .0151 9.00 .0207 9.98 .0033 10.99 .0090 11.99 .0039 13.00 .0039 14.01 .0031 14.99 .0038
+ 16.02 .0023 17.00 .0026 17.98 .0069 19.00 .0020 20.01 .0017 21.02 .0007 22.02 .0006 22.22 .0002
+ 22.93 .0001 24.05 .0003 25.04 .0002 25.99 .0003 27.00 .0003 29.03 .0003))
+
+ (c-d3 '(1.01 .1033 2.00 .0588 3.00 .0184 4.00 .0725 5.00 .0720 6.01 .0251 7.01 .0292
+ 8.02 .0069 9.00 .0094 10.00 .0159 11.02 .0134 12.00 .0008 13.01 .0053 14.01 .0204 15.01 .0122
+ 16.02 .0024 17.03 .0044 18.02 .0069 19.03 .0043 20.01 .0024 21.02 .0020 22.03 .0006 23.03 .0005
+ 24.02 .0006 25.01 .0011 26.01 .0006 27.03 .0007 28.04 .0005 29.04 .0003 30.02 .0001 31.03 .0002
+ 32.04 .0003 36.02 .0002 38.03 .0001 39.06 .0002 40.01 .0002 42.09 .0001 43.08 .0001 44.05 .0002))
+
+ (c-ds3 '(1.01 .1622 2.01 .1721 3.02 .0068 4.02 .0256 5.03 .0568 6.02 .0438 7.03 .0061
+ 8.04 .0086 9.04 .0050 10.06 .0045 11.07 .0012 12.10 .0025 13.08 .0028 14.11 .0014 15.07 .0060
+ 16.07 .0014 17.13 .0026 18.08 .0015 19.13 .0007 20.13 .0003 21.15 .0003 22.06 .0004 23.10 .0002
+ 24.15 .0001 25.12 .0001 26.16 .0002 27.20 .0001))
+
+ (c-e3 '(1.00 .1620 2.01 .0201 3.01 .0224 4.02 .0903 5.03 .0425 6.01 .0323 7.02 .0089
+ 8.11 .0023 9.02 .0050 10.03 .0055 11.05 .0038 12.04 .0099 13.04 .0062 14.03 .0027 15.06 .0040
+ 16.07 .0035 17.07 .0089 18.06 .0013 19.05 .0012 20.08 .0004 21.06 .0008 22.09 .0002 23.08 .0008
+ 24.09 .0005 25.08 .0006 26.65 .0001 27.13 .0001 29.10 .0002 30.10 .0001 31.10 .0002 32.11 .0001
+ 35.12 .0003 36.10 .0002 37.15 .0003 38.17 .0001))
+
+ (c-f3 '(.99 .0412 1.99 .0398 2.99 .1009 3.99 .0605 4.97 .0481 5.96 .0358 6.96 .0065
+ 7.83 .0052 7.97 .0050 8.95 .0042 9.94 .0038 10.95 .0044 11.94 .0120 12.93 .0044 13.92 .0074
+ 14.92 .0037 15.92 .0030 16.92 .0017 17.90 .0021 18.90 .0016 19.89 .0016 20.89 .0002 22.86 .0013
+ 23.87 .0014 24.87 .0006 25.86 .0003 26.88 .0001 29.84 .0004 30.83 .0002 31.82 .0001 32.83 .0001
+ 33.81 .0001 34.81 .0002 35.82 .0003 37.80 .0002))
+
+ (c-fs3 '(1.00 .0386 2.00 .0915 3.00 .0406 4.01 .0601 5.00 .0460 5.99 .0213 7.01 .0148
+ 8.00 .0085 9.00 .0073 10.00 .0017 11.01 .0191 12.00 .0069 13.00 .0057 14.02 .0023 15.01 .0059
+ 16.00 .0010 17.02 .0006 18.01 .0019 19.00 .0012 20.02 .0002 20.99 .0004 22.01 .0013 23.02 .0007
+ 24.02 .0002 24.94 .0001 27.03 .0001 28.02 .0002 29.00 .0001 31.01 .0001 32.01 .0001 33.02 .0003
+ 34.03 .0002))
+
+ (c-g3 '(1.01 .0124 1.99 .0359 2.98 .0602 3.98 .0390 4.98 .0496 5.98 .0070 6.98 .0121
+ 7.97 .0089 8.97 .0044 9.97 .0068 10.97 .0085 11.96 .0110 12.95 .0034 13.95 .0099 14.95 .0059
+ 15.95 .0003 16.94 .0014 17.94 .0005 18.94 .0008 19.95 .0004 20.94 .0007 21.39 .0001 22.95 .0002
+ 24.93 .0001 25.92 .0002 27.91 .0001 29.91 .0005 30.94 .0001 31.93 .0002 33.90 .0001))
+
+ (c-gs3 '(1.00 .0509 1.99 .1477 3.00 .0407 4.00 .0514 5.00 .0367 6.00 .0032 7.02 .0097
+ 8.00 .0090 9.07 .0009 10.03 .0069 10.99 .0020 12.03 .0010 13.02 .0019 14.06 .0010 15.02 .0010
+ 16.03 .0008 17.03 .0003 18.05 .0002 18.98 .0004 20.09 .0002 21.03 .0001 28.01 .0001))
+
+ (c-a3 '(1.00 .0110 2.01 .0315 3.02 .1476 4.03 .0358 5.01 .0391 6.02 .0638 7.03 .0692
+ 8.02 .0039 9.04 .0218 10.04 .0342 11.05 .0335 12.04 .0187 13.05 .0167 14.06 .0168 15.06 .0035
+ 16.07 .0019 17.07 .0014 18.08 .0040 19.07 .0070 20.08 .0014 21.09 .0015 22.08 .0003 23.10 .0003
+ 24.08 .0011 25.10 .0003 26.12 .0013 27.13 .0009 28.13 .0006 29.12 .0003 30.11 .0002 31.13 .0002
+ 33.15 .0002 34.13 .0001 36.15 .0001 41.16 .0002 44.18 .0001 47.17 .0001))
+
+ (c-as3 '(1.00 .0140 2.00 .0411 3.00 .0723 4.00 .1057 5.00 .0044 6.00 .0248 6.98 .0048
+ 8.00 .0014 9.00 .0304 9.99 .0184 10.99 .0130 12.00 .0159 13.00 .0107 13.99 .0021 15.00 .0015
+ 15.99 .0020 17.00 .0028 18.00 .0067 19.00 .0005 20.04 .0003 21.00 .0003 22.02 .0001 23.98 .0003
+ 25.01 .0007 26.01 .0009 27.00 .0003 28.02 .0002 28.98 .0002 30.00 .0002 31.01 .0002 32.01 .0002
+ 32.99 .0003 33.99 .0001 35.02 .0002 37.00 .0002 38.98 .0003 43.98 .0001 44.99 .0001))
+
+ (c-b3 '(1.00 .0648 2.00 .0397 3.00 .0872 4.01 .0429 5.00 .0213 6.01 .0524 7.00 .0064
+ 8.03 .0162 9.02 .0212 10.01 .0175 11.02 .0256 12.03 .0038 13.03 .0039 14.04 .0056 15.03 .0008
+ 16.08 .0005 17.03 .0032 18.04 .0010 19.04 .0011 20.04 .0002 21.06 .0010 22.05 .0002 23.08 .0011
+ 24.09 .0005 25.12 .0003 26.07 .0002 27.03 .0001 39.10 .0002))
+
+ (c-c4 '(1.00 .0472 2.00 .1961 3.00 .1030 4.00 .0974 5.00 .0183 6.00 .0397 7.00 .0158
+ 8.00 .0170 8.99 .0253 10.00 .0129 10.99 .0121 11.99 .0103 12.98 .0055 14.03 .0004 14.99 .0012
+ 15.99 .0051 16.99 .0009 17.99 .0012 19.00 .0004 19.98 .0015 21.02 .0002 22.00 .0009 22.99 .0007
+ 24.01 .0004 25.00 .0002 26.00 .0003 28.00 .0002 28.97 .0002 31.00 .0002 32.98 .0003 33.98 .0001
+ 34.97 .0001 35.98 .0002 37.97 .0002 38.97 .0001))
+
+ (c-cs4 '(1.00 .1199 2.00 .0345 3.01 .0978 4.00 .0466 5.02 .0070 6.01 .0258 7.02 .0241
+ 8.01 .0070 9.02 .0161 10.02 .0124 11.02 .0145 12.02 .0101 13.02 .0026 14.03 .0011 15.02 .0028
+ 16.03 .0011 17.04 .0005 18.02 .0003 19.05 .0012 20.07 .0004 21.06 .0011 22.06 .0007 23.04 .0007
+ 24.05 .0005 26.07 .0003 27.04 .0002 28.05 .0002 29.06 .0001 32.05 .0001 33.06 .0002 35.07 .0002
+ 36.07 .0001 37.07 .0002))
+
+ (c-d4 '(1.00 .0657 2.00 .0681 3.00 .1031 3.99 .0157 4.99 .0570 5.98 .0160 6.99 .0236
+ 7.98 .0259 8.99 .0144 9.98 .0154 10.98 .0046 11.97 .0104 12.98 .0024 13.97 .0020 14.97 .0012
+ 15.97 .0010 16.97 .0004 17.95 .0008 18.97 .0005 19.98 .0007 20.98 .0009 21.93 .0004 22.00 .0003
+ 22.94 .0002 23.95 .0002 24.98 .0001 25.97 .0002 26.96 .0001 28.94 .0002 29.94 .0002 30.94 .0002
+ 32.97 .0001 33.97 .0001 34.95 .0001 36.93 .0001))
+
+ (c-ds4 '(1.00 .3562 1.99 .0664 2.99 .1446 3.98 .0393 4.97 .0363 5.97 .0237 6.96 .0366
+ 7.95 .0079 8.96 .0127 9.95 .0148 10.95 .0143 11.94 .0031 12.96 .0022 13.94 .0032 14.92 .0004
+ 15.92 .0007 16.90 .0007 17.92 .0007 18.92 .0012 19.94 .0005 20.89 .0003 21.88 .0001 22.89 .0005
+ 23.87 .0004 24.87 .0001 25.89 .0007 26.87 .0001 29.85 .0001 30.83 .0001 31.82 .0001 32.82 .0002
+ 33.82 .0001))
+
+ (c-e4 '(1.00 .0390 2.01 .1863 3.02 .0265 4.02 .0184 5.02 .0319 6.03 .0456 7.04 .0122
+ 8.04 .0149 9.05 .0159 10.05 .0067 11.06 .0044 12.06 .0053 13.08 .0012 14.08 .0008 15.08 .0007
+ 16.09 .0021 17.09 .0005 18.09 .0021 19.13 .0016 20.12 .0004 21.12 .0003 22.14 .0003 23.12 .0003
+ 24.13 .0003 25.14 .0005 26.14 .0002 27.15 .0002 28.16 .0002 29.18 .0002 30.17 .0002 31.16 .0002
+ 36.21 .0001))
+
+ (c-f4 '(1.00 .1183 1.99 .1142 2.99 .1085 3.98 .0306 4.99 .0252 5.97 .0272 6.97 .0290
+ 7.97 .0142 8.97 .0112 9.96 .0079 10.96 .0038 11.97 .0026 12.96 .0014 13.95 .0007 14.94 .0011
+ 15.95 .0008 16.94 .0011 17.03 .0001 17.94 .0001 18.95 .0004 19.94 .0003 20.94 .0007 21.92 .0002
+ 23.92 .0002 24.92 .0002 25.90 .0002 26.90 .0002 27.89 .0001 28.89 .0002 30.89 .0001))
+
+ (c-fs4 '(1.00 .1140 2.00 .0935 3.00 .0504 3.99 .0715 4.99 .0063 6.00 .0808 6.99 .0099
+ 8.00 .0093 9.00 .0093 9.99 .0019 10.99 .0050 11.99 .0017 12.99 .0021 14.00 .0003 14.99 .0010
+ 16.00 .0015 17.00 .0019 17.95 .0002 18.00 .0002 18.99 .0002 19.99 .0003 21.00 .0002 21.99 .0003
+ 23.99 .0001 24.98 .0001 26.02 .0001 27.01 .0001 28.00 .0002))
+
+ (c-g4 '(1.00 .0809 1.99 .1377 2.99 .0348 3.99 .0337 4.98 .0177 5.98 .0295 6.98 .0266
+ 7.98 .0063 8.98 .0105 9.97 .0016 10.97 .0022 11.98 .0029 12.97 .0018 13.96 .0008 14.99 .0023
+ 15.97 .0012 16.96 .0009 17.97 .0002 18.95 .0006 20.94 .0002 20.99 .0002 22.95 .0002 23.94 .0002
+ 24.94 .0003 25.97 .0003 26.95 .0002))
+
+ (c-gs4 '(1.00 .2601 1.99 .1726 2.99 .0722 3.99 .0276 4.99 .0535 5.99 .0103 6.99 .0244
+ 7.99 .0046 8.98 .0035 9.99 .0088 10.98 .0038 11.98 .0008 12.96 .0006 13.98 .0020 14.98 .0016
+ 15.98 .0008 16.97 .0003 17.97 .0005 18.98 .0006 19.96 .0005 20.96 .0001 21.96 .0003 23.96 .0002
+ 24.96 .0003 25.96 .0002))
+
+ (c-a4 '(.99 .0363 1.98 .2481 2.98 .0514 3.97 .0365 4.97 .0468 5.95 .0182 6.95 .0333
+ 7.94 .0106 8.93 .0048 9.92 .0048 10.92 .0016 11.90 .0010 12.89 .0011 13.92 .0023 14.90 .0014
+ 15.88 .0007 16.87 .0002 17.89 .0001 18.85 .0004 19.84 .0002 20.84 .0003 21.84 .0004 22.83 .0003
+ 23.86 .0002 24.84 .0002 26.82 .0001))
+
+ (c-as4 '(.99 .0564 1.99 .1983 2.98 .0520 3.97 .0442 4.97 .0260 5.96 .0139 6.96 .0099
+ 7.94 .0046 8.94 .0178 9.94 .0032 10.93 .0021 11.00 .0002 11.93 .0001 12.92 .0038 13.91 .0011
+ 14.90 .0006 15.92 .0004 16.89 .0004 17.89 .0002 18.87 .0005 19.87 .0003 20.86 .0003 21.85 .0003
+ 22.85 .0001 23.85 .0001 24.85 .0001 25.85 .0002 26.84 .0002))
+
+ (c-b4 '(.99 .0774 1.98 .1289 2.96 .1071 3.95 .0216 4.94 .0346 5.93 .0108 6.91 .0239
+ 7.90 .0056 8.88 .0045 9.88 .0014 10.87 .0057 11.85 .0018 12.85 .0035 13.83 .0007 14.84 .0003
+ 15.80 .0003 16.79 .0008 17.78 .0003 18.78 .0002 19.76 .0004 20.75 .0005 21.73 .0002 23.71 .0001
+ 24.68 .0001))
+
+ (c-c5 '(.99 .4933 1.97 .1293 2.95 .0971 4.92 .0189 5.91 .0031 6.88 .0093 7.87 .0143
+ 8.85 .0063 9.84 .0010 10.82 .0023 11.81 .0015 12.79 .0006 13.78 .0009 14.76 .0007 15.75 .0004
+ 16.72 .0007 17.71 .0002 18.68 .0008 19.67 .0004 20.66 .0003))
+
+ (c-cs5 '(.99 .1576 1.99 .0760 2.98 .0560 3.97 .1172 4.96 .0433 5.96 .0029 6.95 .0079
+ 7.95 .0058 8.93 .0025 9.93 .0014 10.93 .0054 11.92 .0005 12.92 .0004 13.90 .0009 14.90 .0015
+ 15.89 .0003 16.87 .0002 17.87 .0004 18.87 .0002 19.86 .0002 20.86 .0002 21.86 .0003 22.85 .0002))
+
+ (c-d5 '(1.01 .1243 2.02 .0648 3.03 .0586 4.04 .0543 5.05 .0183 6.07 .0046 7.08 .0080
+ 8.09 .0027 9.10 .0053 10.12 .0036 11.14 .0014 12.14 .0004 13.16 .0004 14.15 .0007 15.17 .0005
+ 17.20 .0006 18.22 .0002 19.22 .0002 21.24 .0001))
+
+ (c-ds5 '(1.01 .1367 2.02 .0170 3.02 .0192 4.03 .0425 5.04 .0143 6.05 .0064 7.06 .0057
+ 8.06 .0028 9.08 .0027 10.09 .0051 11.09 .0009 12.09 .0001 13.10 .0014 14.11 .0005 15.13 .0003
+ 16.13 .0003 17.14 .0002 19.15 .0003 20.17 .0004 21.17 .0001))
+
+ (c-e5 '(1.02 .2402 2.03 .0419 3.05 .1068 5.08 .0164 6.10 .0019 7.11 .0044 8.13 .0018
+ 9.15 .0044 10.17 .0021 11.18 .0003 12.20 .0007 13.21 .0011 14.24 .0003 15.24 .0008 16.27 .0001
+ 17.28 .0001 18.31 .0001))
+
+ (c-f5 '(1.01 .1166 2.03 .0750 3.04 .0532 4.05 .0620 5.06 .0054 6.07 .0141 7.08 .0027
+ 8.10 .0015 9.09 .0021 10.13 .0006 11.13 .0009 12.14 .0004 13.15 .0008 14.17 .0003 15.18 .0002
+ 17.19 .0003 18.20 .0002))
+
+ (c-fs5 '(1.00 .1595 2.00 .0985 3.01 .1045 4.01 .0147 5.01 .0078 6.01 .0016 7.01 .0020
+ 8.02 .0007 9.02 .0015 10.03 .0008 11.03 .0006 12.02 .0004 13.02 .0009 14.03 .0006 15.02 .0005
+ 16.03 .0002 17.04 .0001))
+
+ (c-g5 '(1.00 .1740 1.99 .0431 2.99 .1899 3.99 .0201 4.98 .0009 5.98 .0031 6.98 .0055
+ 7.97 .0051 8.97 .0007 9.96 .0007 10.95 .0006 11.95 .0009 12.95 .0008 13.96 .0002 14.94 .0001
+ 15.95 .0002))
+
+ (c-gs5 '(1.00 .1902 1.99 .0327 2.98 .0551 3.98 .0157 4.97 .0078 5.97 .0030 6.96 .0035
+ 7.96 .0020 8.95 .0017 9.94 .0011 10.94 .0005 11.93 .0007 12.93 .0004 13.92 .0002 14.93 .0003))
+
+ (c-a5 '(.99 .4175 1.99 .0209 2.98 .0274 3.97 .0220 4.96 .0061 5.96 .0020 6.96 .0038
+ 7.95 .0009 8.95 .0014 9.93 .0005 10.93 .0005 11.91 .0007 12.91 .0002 13.91 .0001 14.91 .0001))
+
+ (c-as5 '(1.00 .4648 2.00 .0475 3.01 .1268 4.01 .0164 5.02 .0035 6.02 .0018 7.02 .0033
+ 8.03 .0028 9.03 .0008 10.03 .0006 11.03 .0005 12.04 .0006 13.05 .0003 14.04 .0001))
+
+ (c-b5 '(1.01 .2812 2.02 .1380 3.02 .0722 4.03 .0215 5.04 .0036 6.06 .0018 7.05 .0005
+ 8.07 .0015 9.08 .0013 10.08 .0003 11.10 .0002 12.11 .0003 13.11 .0002))
+
+ (c-c6 '(1.01 .2553 2.01 .1160 3.02 .0171 4.02 .0272 5.02 .0020 6.03 .0062 7.03 .0012
+ 8.04 .0011 9.05 .0007 10.05 .0007 11.06 .0002 12.06 .0001 12.08 .0001))
+
+ (c-cs6 '(1.01 .1045 2.02 .1220 3.04 .0220 4.05 .0094 5.06 .0021 6.07 .0031 7.09 .0018
+ 8.10 .0020 9.11 .0014 10.12 .0003 11.13 .0006))
+
+ (c-d6 '(1.00 .0653 1.99 .2499 2.99 .0334 3.98 .0098 4.98 .0091 5.98 .0007 6.97 .0011
+ 7.97 .0008 8.96 .0042 9.96 .0003 10.95 .0004))
+
+ (c-ds6 '(.99 .0485 1.99 .1325 2.98 .0152 3.98 .0064 4.97 .0043 5.97 .0007 6.96 .0007
+ 7.97 .0006 8.96 .0003 9.95 .0004))
+
+ (c-e6 '(1.01 .1797 2.01 .0750 4.03 .0065 5.04 .0018 6.04 .0012 7.04 .0004 8.06 .0003
+ 9.06 .0003))
+
+ ;; clarinet?
+ (cl-d3 '(1.01 .1722 2.00 .0056 2.99 .1609 3.99 .0333 5.00 .1157 5.99 .1149 6.98 .0079
+ 7.98 .0620 8.99 .0601 9.99 .0104 10.98 .0134 11.97 .0122 12.99 .0058 13.98 .0110 14.98 .0029
+ 15.97 .0045 16.98 .0023 17.98 .0010 18.97 .0016 19.96 .0021 20.96 .0008 21.97 .0021 22.96 .0001
+ 23.96 .0012 24.95 .0003 25.97 .0002 26.96 .0003 27.95 .0002 30.96 .0002 32.94 .0002 34.96 .0001
+ 35.95 .0002 37.93 .0001))
+
+ (cl-ds3 '(.99 .1038 1.98 .0043 2.96 .0953 3.97 .0013 4.94 .1057 5.93 .0145 6.93 .0787
+ 7.91 .0328 8.89 .0086 9.90 .0088 10.88 .0128 11.86 .0005 12.86 .0085 13.84 .0026 14.83 .0051
+ 15.81 .0030 16.82 .0008 17.79 .0026 18.78 .0013 19.78 .0015 20.76 .0011 22.74 .0012 23.72 .0002
+ 24.71 .0006 25.70 .0003 26.70 .0002 28.67 .0002 30.64 .0002 31.64 .0001 32.63 .0001 33.61 .0003
+ 35.59 .0002))
+
+ (cl-e3 '(1.00 .0825 1.99 .0024 2.97 .0406 3.96 .0042 4.94 .0683 6.40 .0010 6.92 .0709
+ 7.92 .0099 8.91 .0059 9.89 .0055 10.88 .0111 11.90 .0009 12.86 .0126 13.87 .0021 14.84 .0110
+ 15.83 .0010 16.83 .0057 17.81 .0007 18.80 .0037 19.78 .0008 20.78 .0016 21.75 .0006 22.75 .0008
+ 23.73 .0005 24.74 .0007 26.72 .0004 27.68 .0002 29.67 .0003 31.66 .0003 33.64 .0002))
+
+ (cl-f3 '(.99 .0685 1.98 .0012 2.98 .0854 3.98 .0029 4.96 .0507 5.97 .0017 6.96 .0507
+ 7.94 .0027 8.94 .0092 9.94 .0084 10.92 .0116 11.91 .0018 12.92 .0039 13.92 .0003 14.89 .0013
+ 15.88 .0019 16.87 .0012 17.86 .0010 18.87 .0011 19.86 .0008 20.85 .0008 21.83 .0002 23.81 .0004
+ 24.83 .0002 25.80 .0003 27.78 .0002 29.78 .0001))
+
+ (cl-fs3 '(1.00 .1546 1.99 .0015 2.99 .0594 4.00 .0014 5.00 .0268 6.00 .0019 7.00 .0170
+ 7.97 .0005 9.00 .0110 9.99 .0006 10.99 .0077 11.99 .0013 12.99 .0025 14.01 .0004 14.99 .0018
+ 15.98 .0001 16.98 .0013 17.97 .0003 18.98 .0013 20.97 .0001 21.97 .0004 22.96 .0002 23.98 .0002
+ 25.99 .0001))
+
+ (cl-g3 '(.99 .1660 2.00 .0016 2.99 .0889 3.99 .0017 4.99 .0430 6.00 .0009 6.98 .0128
+ 8.00 .0040 8.98 .0077 9.99 .0017 10.98 .0052 11.98 .0011 12.98 .0012 13.97 .0008 14.98 .0010
+ 15.97 .0005 16.98 .0005 17.96 .0007 18.97 .0002 19.96 .0004 20.96 .0003 22.94 .0003 23.95 .0002
+ 24.96 .0002 25.93 .0001 26.94 .0002 27.95 .0001))
+
+ (cl-gs3 '(1.00 .1107 2.00 .0016 2.99 .0872 3.99 .0028 4.98 .0293 5.97 .0020 6.96 .0202
+ 7.99 .0019 8.95 .0118 9.94 .0028 10.95 .0040 11.92 .0006 12.95 .0030 13.92 .0002 14.92 .0010
+ 15.91 .0005 16.91 .0015 18.90 .0004 19.89 .0004 20.89 .0002 21.88 .0004 22.87 .0002 23.88 .0001
+ 24.87 .0001))
+
+ (cl-a3 '(1.00 .0842 2.01 .0017 3.00 .0420 4.01 .0029 5.00 .0251 6.02 .0041 6.99 .0115
+ 7.96 .0006 8.99 .0032 9.98 .0003 11.00 .0018 11.96 .0003 12.96 .0006 14.00 .0001 14.97 .0001
+ 15.97 .0005 17.95 .0002 18.96 .0001 19.07 .0001 22.06 .0001))
+
+ (cl-as3 '(1.00 .1118 1.99 .0006 2.98 .0383 3.98 .0019 4.98 .0335 5.98 .0034 6.97 .0131
+ 7.94 .0005 8.95 .0024 9.96 .0028 10.96 .0019 11.94 .0012 12.94 .0012 13.93 .0003 14.94 .0007
+ 16.92 .0004 17.90 .0003 18.93 .0002 20.89 .0002 21.90 .0001))
+
+ (cl-b3 '(1.00 .1324 1.99 .0011 3.00 .0693 4.01 .0012 4.99 .0279 5.98 .0044 6.98 .0149
+ 7.97 .0009 8.97 .0028 9.97 .0009 10.98 .0026 11.96 .0003 12.96 .0006 13.95 .0003 15.95 .0001
+ 16.94 .0001))
+
+ (cl-c4 '(1.00 .2335 1.99 .0017 2.99 .1253 4.01 .0023 4.99 .0343 6.01 .0028 6.98 .0023
+ 7.98 .0014 8.98 .0041 10.01 .0003 10.96 .0004 11.94 .0008 12.94 .0002 14.94 .0003 15.94 .0004
+ 16.93 .0002 17.91 .0002 18.91 .0002 19.91 .0001 20.90 .0001))
+
+ (cl-cs4 '(.99 .2609 2.00 .0016 2.99 .1469 3.99 .0040 4.99 .0143 5.97 .0091 6.97 .0055
+ 7.97 .0024 8.96 .0041 9.96 .0015 10.96 .0021 11.95 .0005 12.94 .0011 13.93 .0004 14.94 .0006
+ 15.94 .0004 16.92 .0004 17.93 .0002 18.93 .0001 19.91 .0001 20.91 .0001 21.90 .0002 22.91 .0001))
+
+ (cl-d4 '(1.00 .2056 1.99 .0006 2.99 .1715 3.99 .0010 4.98 .0194 5.99 .0028 6.98 .0106
+ 7.98 .0007 8.97 .0022 9.97 .0005 10.96 .0011 11.97 .0006 12.96 .0006 13.96 .0003 14.95 .0005
+ 15.95 .0003 17.95 .0002 18.94 .0002 20.94 .0001))
+
+ (cl-ds4 '(1.00 .2590 1.98 .0019 2.99 .1336 3.97 .0034 4.97 .0442 5.97 .0017 6.96 .0108
+ 7.96 .0006 8.95 .0031 9.94 .0003 11.93 .0003 12.93 .0004 13.93 .0005 14.92 .0001 15.91 .0003
+ 16.90 .0004 17.90 .0002 18.89 .0001))
+
+ (cl-e4 '(1.00 .2560 2.00 .0013 3.00 .0878 4.00 .0053 5.00 .0304 6.00 .0009 7.00 .0060
+ 7.99 .0007 9.00 .0011 9.99 .0006 10.99 .0006 11.98 .0001 13.99 .0001))
+
+ (cl-f4 '(.99 .1966 1.99 .0021 2.98 .0812 3.96 .0018 4.97 .0248 5.96 .0032 6.96 .0060
+ 7.95 .0024 8.95 .0019 9.94 .0008 10.94 .0007 11.92 .0005 12.91 .0002 13.94 .0001 14.90 .0002
+ 15.91 .0002))
+
+ (cl-fs4 '(1.00 .1555 2.01 .0022 3.01 .1755 4.01 .0005 5.01 .0127 6.02 .0004 7.02 .0031
+ 8.02 .0007 9.02 .0005 10.02 .0002 11.03 .0003 12.02 .0002 14.02 .0001 15.03 .0001 16.04 .0001))
+
+ (cl-g4 '(1.00 .0470 2.00 .0016 3.00 .0787 4.00 .0041 5.00 .0046 6.00 .0010 7.00 .0036
+ 8.00 .0011 9.00 .0012 10.00 .0002 11.00 .0003 13.00 .0001))
+
+ (cl-gs4 '(1.00 .1205 1.99 .0014 2.99 .0145 3.99 .0015 4.99 .0030 5.99 .0005 6.98 .0006
+ 9.00 .0001 9.98 .0001))
+
+ (cl-a4 '(1.00 .2677 2.00 .0592 3.01 .0961 4.01 .0083 5.02 .0075 6.02 .0027 7.03 .0048
+ 8.03 .0031 9.02 .0007 10.03 .0003 11.03 .0001))
+
+ (cl-as4 '(1.00 .1363 2.01 .0056 3.00 .0168 4.01 .0026 5.01 .0112 6.00 .0011 7.01 .0011
+ 8.01 .0003 10.00 .0002 12.02 .0001))
+
+ (cl-b4 '(1.01 .0312 2.01 .0042 3.02 .0061 4.02 .0127 5.03 .0090 6.04 .0002 7.04 .0021
+ 8.05 .0008 11.06 .0001))
+
+ (cl-c5 '(1.00 .2597 2.00 .0052 3.00 .0337 4.00 .0012 5.00 .0025 6.00 .0014 7.00 .0007
+ 7.99 .0004 8.99 .0003 10.00 .0004))
+
+ (cl-cs5 '(1.00 .1894 2.00 .0060 3.00 .0250 4.01 .0022 5.01 .0048 6.00 .0004 8.01 .0001
+ 10.01 .0001))
+
+ (cl-d5 '(1.00 .1727 2.01 .0013 3.00 .0066 4.01 .0011 5.00 .0013 5.99 .0008 8.02 .0001))
+
+ (cl-ds5 '(1.00 .3538 2.00 .0053 3.01 .0757 4.01 .0009 5.01 .0045 6.02 .0008 7.02 .0011
+ 8.01 .0003 9.02 .0005 10.01 .0002 11.02 .0001 12.02 .0002))
+
+ (cl-e5 '(1.00 .1647 2.00 .0048 3.00 .0524 3.99 .0055 4.99 .0030 5.98 .0011 6.99 .0004
+ 7.99 .0003))
+
+ (cl-f5 '(.99 .1880 1.99 .0126 2.99 .0222 3.98 .0070 4.98 .0135 5.97 .0020 6.97 .0012
+ 7.96 .0001 8.96 .0007 9.95 .0003))
+
+ (cl-fs5 '(1.00 .3103 2.00 .0104 3.00 .0335 4.00 .0078 5.00 .0026 6.01 .0005 7.01 .0006
+ 8.00 .0003))
+
+ (cl-g5 '(1.01 .4163 2.01 .0446 3.02 .0290 4.03 .0031 5.02 .0004 6.03 .0002 7.05 .0001
+ 8.05 .0001))
+
+ (cl-gs5 '(1.01 .2150 2.00 .0334 3.00 .0012 4.02 .0003 5.02 .0002))
+
+ (cl-a5 '(1.01 .5463 2.01 .0429 3.02 .0317 4.02 .0159 5.03 .0012 6.04 .0005 7.04 .0005
+ 8.05 .0002))
+
+ (cl-as5 '(1.00 .3802 2.00 .0397 3.01 .0186 4.01 .0102 5.01 .0020 6.01 .0001 7.01 .0002
+ 8.02 .0003 9.02 .0002 10.02 .0001 11.02 .0001 12.02 .0002))
+
+ (cl-b5 '(1.00 .0896 2.00 .0851 3.00 .0081 4.00 .0024 5.00 .0010 6.00 .0001 7.00 .0002))
+
+ (cl-c6 '(1.00 .1740 2.00 .0081 3.01 .0111 4.01 .0087 5.01 .0005 6.01 .0007 7.01 .0001
+ 9.01 .0002 10.02 .0002))
+
+ (cl-cs6 '(1.00 .1295 1.99 .0270 2.99 .0012 3.99 .0004))
+
+ (cl-d6 '(1.00 .1700 2.01 .0603 3.01 .0169 4.01 .0031 5.01 .0007 6.01 .0002))
+
+ (cl-ds6 '(1.01 .2624 2.02 .0042 3.03 .0049 4.03 .0015 5.04 .0001))
+
+ (cl-e6 '(1.02 .0632 2.03 .0115 3.04 .0011 4.06 .0006))
+
+ (cl-f6 '(1.02 .0748 2.03 .0535 3.05 .0044 4.07 .0009 5.08 .0001 7.12 .0001 8.13 .0001))
+
+ (cl-fs6 '(1.02 .0305 2.03 .0175 3.04 .0005 4.05 .0002))
+
+ (cl-g6 '(1.03 .0026 2.04 .0008))
+
+ (cl-gs6 '(1.03 .0015 2.00 .0002))
+
+ (cl-a6 '(1.03 .0043 2.05 .0010))
+
+ (cl-as6 '(1.05 .0008 2.00 .0001))
+
+ ;; french horn?
+ (fh-as1 '(1.01 .0041 2.00 .0015 3.01 .0121 4.02 .0111 5.02 .0343 6.03 .0165 7.04 .0066
+ 8.03 .0064 9.05 .0049 10.06 .0012 11.05 .0093 12.07 .0029 13.07 .0042 14.08 .0040 15.08 .0019
+ 16.09 .0013 17.10 .0009 18.04 .0002 19.03 .0002 20.12 .0003 21.13 .0003 22.13 .0002 23.13 .0002))
+
+ (fh-b1 '(1.01 .0035 2.03 .0064 3.04 .0087 4.08 .0087 5.12 .0049 6.08 .0189 7.10 .0304
+ 8.12 .0205 9.16 .0026 10.18 .0039 11.20 .0006 12.11 .0029 13.15 .0037 14.24 .0014 15.26 .0010
+ 16.29 .0005 17.19 .0003 18.21 .0007 19.23 .0005 20.25 .0004 21.33 .0003 22.36 .0001 23.32 .0002
+ 24.33 .0002 25.33 .0001 26.39 .0002 27.42 .0002))
+
+ (fh-c2 '(1.02 .0034 2.02 .0059 3.01 .0083 4.02 .0274 5.03 .0206 6.03 .0155 7.04 .0131
+ 8.03 .0073 9.05 .0014 10.03 .0064 11.05 .0055 12.06 .0109 13.08 .0037 14.10 .0012 15.10 .0010
+ 16.01 .0004 17.05 .0009 18.06 .0008 19.06 .0006 20.09 .0004 21.11 .0002 22.14 .0002 23.09 .0002
+ 24.08 .0001 25.08 .0002 26.07 .0002 27.12 .0002 28.16 .0001 32.11 .0001))
+
+ (fh-cs2 '(1.01 .0038 1.99 .0124 2.98 .0065 4.00 .0260 5.00 .0138 5.99 .0093 6.97 .0077
+ 7.95 .0055 8.97 .0061 9.97 .0016 10.95 .0034 11.96 .0036 12.14 .0010 12.94 .0009 13.97 .0008
+ 14.86 .0004 15.89 .0006 16.91 .0007 17.93 .0004 18.94 .0002 19.95 .0001 20.77 .0001 21.78 .0002
+ 22.86 .0001 23.89 .0002))
+
+ (fh-d2 '(1.01 .0153 2.01 .0192 3.01 .0216 4.01 .0371 5.01 .0259 6.02 .0188 7.02 .0076
+ 8.04 .0009 9.03 .0038 10.03 .0065 11.03 .0075 12.03 .0026 13.03 .0005 14.04 .0009 15.06 .0008
+ 16.04 .0006 17.03 .0004 18.03 .0003 19.04 .0002 23.03 .0002))
+
+ (fh-ds2 '(1.00 .0234 1.98 .0227 2.96 .0129 3.97 .0333 4.96 .0315 5.95 .0252 6.93 .0076
+ 7.94 .0061 8.91 .0028 9.89 .0096 10.90 .0089 11.89 .0024 12.88 .0022 13.88 .0019 14.87 .0010
+ 15.79 .0006 16.79 .0003 17.79 .0002 18.69 .0002 19.68 .0003 20.70 .0002 21.70 .0002))
+
+ (fh-e2 '(1.00 .0150 1.99 .0230 3.01 .0204 4.00 .0298 5.02 .0112 6.03 .0135 7.02 .0019
+ 8.03 .0061 9.01 .0099 10.04 .0053 11.03 .0006 12.04 .0028 13.04 .0016 14.04 .0015 15.03 .0009
+ 16.02 .0005 17.05 .0002 20.02 .0002 21.02 .0001 24.00 .0002 25.03 .0001))
+
+ (fh-f2 '(.97 .0088 1.96 .0127 2.97 .0179 3.96 .0163 4.94 .0421 5.91 .0165 6.96 .0019
+ 7.93 .0020 8.91 .0112 9.85 .0035 10.91 .0017 12.02 .0004 12.83 .0014 13.79 .0010 14.79 .0007
+ 15.75 .0002 16.73 .0003 17.74 .0007 18.74 .0005 19.73 .0001 20.68 .0002 21.66 .0002 22.65 .0002
+ 23.63 .0001 24.65 .0001))
+
+ (fh-fs2 '(1.00 .0035 1.99 .0136 2.97 .0394 3.96 .0379 4.98 .0330 5.97 .0111 6.94 .0156
+ 7.94 .0108 8.96 .0076 9.95 .0025 10.95 .0021 11.93 .0026 12.93 .0014 13.89 .0008 14.87 .0006
+ 15.78 .0001 16.94 .0001 17.93 .0001 18.93 .0001 19.89 .0001))
+
+ (fh-g2 '(1.01 .0150 2.01 .0182 3.04 .1047 4.04 .0662 5.03 .0448 6.06 .0018 7.06 .0034
+ 8.06 .0202 9.09 .0051 10.09 .0070 11.08 .0060 12.11 .0022 13.12 .0011 14.13 .0005 15.20 .0001
+ 16.09 .0002 17.14 .0002 18.14 .0002 19.14 .0002 20.16 .0002 21.15 .0001 22.15 .0001))
+
+ (fh-gs2 '(.99 .0092 2.00 .0177 3.00 .0664 3.98 .0447 4.99 .0223 5.99 .0144 7.00 .0124
+ 7.97 .0096 8.97 .0046 9.96 .0011 10.99 .0021 12.00 .0010 12.99 .0007 13.93 .0007 14.92 .0007
+ 15.94 .0005 16.94 .0003 17.90 .0002 18.88 .0001 19.87 .0002 20.86 .0002 21.86 .0001))
+
+ (fh-a2 '(1.00 .0063 2.01 .0609 3.03 .0699 4.05 .1365 5.04 .0249 6.05 .0103 7.07 .0200
+ 8.08 .0059 9.10 .0063 10.09 .0046 11.10 .0015 12.13 .0008 13.14 .0006 14.07 .0004 15.05 .0004
+ 16.08 .0004 17.10 .0002 18.12 .0002 19.10 .0001))
+
+ (fh-as2 '(1.00 .0026 2.02 .0329 3.03 .0926 4.04 .0530 5.07 .0041 6.07 .0072 7.09 .0076
+ 8.10 .0053 9.11 .0057 10.13 .0017 11.16 .0005 12.21 .0001 13.09 .0003 14.11 .0003 15.18 .0003
+ 16.17 .0001))
+
+ (fh-b2 '(1.01 .0154 2.02 .0506 3.05 .1042 4.05 .0643 5.06 .0151 6.08 .0102 7.09 .0045
+ 8.11 .0040 9.12 .0033 10.12 .0015 11.13 .0006 12.16 .0004 13.18 .0003 14.95 .0001 15.98 .0001
+ 16.99 .0001 18.02 .0001))
+
+ (fh-c3 '(1.01 .0147 2.02 .0897 3.01 .1180 4.01 .0323 5.02 .0133 6.04 .0226 7.04 .0033
+ 8.06 .0023 9.02 .0019 10.03 .0010 11.04 .0009 12.06 .0003 13.04 .0002 14.05 .0002 15.05 .0002
+ 16.01 .0002 16.94 .0001))
+
+ (fh-cs3 '(1.01 .0345 2.00 .1083 2.99 .0911 4.01 .0280 5.01 .0071 6.00 .0123 7.00 .0043
+ 8.01 .0034 9.01 .0014 10.02 .0004 10.94 .0003 11.96 .0003 12.96 .0002 14.89 .0001 15.92 .0001))
+
+ (fh-d3 '(1.01 .0488 2.02 .1313 3.03 .1606 4.03 .0029 5.04 .0187 6.05 .0059 7.05 .0018
+ 8.05 .0023 9.05 .0007 10.06 .0003 11.07 .0001 12.08 .0002))
+
+ (fh-ds3 '(1.00 .0619 2.00 .1230 3.01 .0981 4.02 .0299 5.02 .0210 6.03 .0054 7.03 .0023
+ 8.04 .0010 9.04 .0005 10.06 .0002))
+
+ (fh-e3 '(1.00 .0500 2.01 .1076 3.03 .1077 4.04 .0167 5.03 .0138 6.06 .0058 7.07 .0036
+ 8.06 .0007 9.09 .0004 10.07 .0002 11.03 .0001 12.05 .0002))
+
+ (fh-f3 '(1.01 .0368 2.02 .1311 3.02 .0405 4.03 .0139 5.03 .0080 6.04 .0052 7.05 .0015
+ 8.04 .0004 9.06 .0002 10.06 .0002 12.08 .0001))
+
+ (fh-fs3 '(1.01 .0430 2.02 .1877 3.05 .0299 4.05 .0218 5.07 .0067 6.08 .0054 7.10 .0012
+ 8.11 .0010 9.12 .0004 10.13 .0002 11.15 .0001))
+
+ (fh-g3 '(1.01 .0339 2.04 .1965 4.07 .0541 5.08 .0113 6.10 .0049 7.10 .0022 8.13 .0014
+ 9.14 .0008 10.16 .0005))
+
+ (fh-gs3 '(1.02 .0596 2.02 .1865 3.03 .0629 4.04 .0304 5.05 .0087 6.05 .0035 7.07 .0008
+ 8.09 .0004 9.09 .0005 10.10 .0005 11.11 .0002 12.12 .0001))
+
+ (fh-a3 '(1.00 .1160 2.02 .2642 3.02 .0259 4.02 .0127 5.04 .0095 6.04 .0022 7.04 .0013
+ 8.06 .0008 9.04 .0003 10.01 .0001))
+
+ (fh-as3 '(1.01 .0585 2.01 .1648 3.02 .0229 4.02 .0150 5.03 .0084 6.03 .0016 7.06 .0003
+ 9.01 .0002))
+
+ (fh-b3 '(1.01 .0741 2.00 .1581 3.00 .0490 4.01 .0133 5.01 .0045 6.02 .0013 7.03 .0002
+ 8.00 .0001))
+
+ (fh-c4 '(.99 .1378 2.00 .0872 2.99 .0736 3.99 .0065 4.99 .0025 5.97 .0009 6.98 .0002
+ 7.98 .0005 8.98 .0002))
+
+ (fh-cs4 '(1.01 .2826 2.02 .0676 3.02 .0523 4.03 .0208 5.04 .0069 6.04 .0009 7.05 .0009
+ 8.06 .0011 9.07 .0004 10.07 .0001 11.08 .0002 12.09 .0001))
+
+ (fh-d4 '(1.01 .2849 2.02 .0068 3.03 .0144 4.04 .0066 5.05 .0032 6.07 .0007 7.07 .0003
+ 8.09 .0003))
+
+ (fh-ds4 '(1.00 .2321 2.01 .0612 3.02 .0150 4.03 .0042 5.03 .0007 6.04 .0005 7.05 .0002
+ 8.06 .0001))
+
+ (fh-e4 '(1.01 .1701 2.01 .0303 3.02 .0156 4.03 .0021 5.04 .0009 6.04 .0003 7.04 .0001))
+
+ (fh-f4 '(1.01 .1957 2.01 .0196 3.01 .0087 4.01 .0022 5.01 .0006 6.02 .0002))
+
+ (fh-fs4 '(1.01 .3622 2.02 .0601 3.03 .0187 4.04 .0043 5.05 .0011 6.06 .0005))
+
+ (fh-g4 '(1.00 .2782 2.01 .0918 3.01 .0080 4.03 .0013 5.03 .0010 6.03 .0003))
+
+ (fh-gs4 '(1.01 .2703 2.02 .0548 3.02 .0083 4.03 .0011 5.03 .0009 6.04 .0003))
+
+ (fh-a4 '(1.01 .4575 2.02 .0245 3.03 .0049 4.04 .0019 5.05 .0008 6.06 .0002))
+
+ (fh-as4 '(1.00 .2524 2.01 .0291 3.02 .0022 4.03 .0011 5.03 .0003))
+
+ (fh-b4 '(1.00 .3254 2.00 .0428 3.00 .0026 4.00 .0006))
+
+ (fh-c5 '(1.00 .1672 2.00 .0223 3.00 .0010 4.00 .0005))
+
+ (fh-cs5 '(1.00 .1209 2.00 .0340 3.00 .0014 4.01 .0004))
+
+ (fh-d5 '(1.01 .0150 2.01 .0313 3.02 .0023 4.03 .0007))
+
+ (fh-ds5 '(1.00 .1633 2.00 .0260 3.00 .0012 4.00 .0002))
+
+ (fh-e5 '(1.00 .1001 2.00 .0146 3.00 .0019 4.00 .0001))
+
+ (fh-f5 '(1.01 .0944 2.01 .0114 3.02 .0016 4.02 .0002))
+
+ (fh-fs5 '(1.01 .1904 2.02 .0076 3.02 .0025 4.03 .0003))
+
+ (fh-g5 '(1.00 .2511 2.00 .0017 3.01 .0010 4.01 .0004))
+
+ (fh-gs5 '(1.00 .1029 1.99 .0050 2.99 .0007 3.99 .0002))
+
+
+
+ (fhf-as1 '(1.01 .0025 1.99 .0008 3.01 .0057 4.02 .0063 5.03 .0268 6.04 .0198 7.04 .0157
+ 8.03 .0160 9.05 .0056 10.05 .0016 11.06 .0059 12.09 .0009 13.10 .0023 14.08 .0022 15.09 .0011
+ 16.10 .0011 17.11 .0012 18.16 .0009 19.16 .0008 20.15 .0005 21.16 .0002 22.15 .0001 23.15 .0001))
+
+ (fhf-b1 '(1.03 .0025 2.07 .0054 5.15 .0276 6.18 .0379 7.21 .0389 8.23 .0176 9.26 .0020
+ 10.29 .0039 11.24 .0002 12.26 .0010 13.28 .0015 14.34 .0010 15.37 .0009 16.42 .0010 17.47 .0027
+ 18.49 .0015 19.52 .0010 20.56 .0005 21.57 .0004 22.59 .0004 23.60 .0003 24.61 .0003 25.65 .0002
+ 26.67 .0002 27.66 .0001 28.71 .0002 29.75 .0001))
+
+ (fhf-c2 '(1.02 .0023 2.03 .0041 3.03 .0059 4.05 .0291 5.05 .0280 6.06 .0396 7.06 .0428
+ 8.07 .0111 9.08 .0018 10.10 .0049 11.12 .0052 12.12 .0075 13.12 .0021 14.15 .0009 15.18 .0008
+ 16.21 .0009 17.22 .0012 18.23 .0008 19.23 .0003 20.24 .0003 21.23 .0002 22.22 .0002 23.22 .0002
+ 24.25 .0001 25.27 .0002 26.27 .0001 28.25 .0001 30.29 .0001 32.31 .0001))
+
+ (fhf-cs2 '(1.03 .0031 2.02 .0111 3.02 .0074 4.01 .0370 5.01 .0307 6.03 .0330 7.03 .0281
+ 8.02 .0089 9.02 .0097 9.21 .0016 10.03 .0014 11.04 .0044 12.03 .0039 12.96 .0004 14.09 .0011
+ 15.10 .0006 16.10 .0014 17.09 .0011 18.09 .0006 19.10 .0005 20.10 .0004 21.08 .0002 22.10 .0003
+ 22.28 .0002 23.07 .0001 24.04 .0002 25.09 .0001 26.10 .0001 27.10 .0001 32.10 .0001))
+
+ (fhf-d2 '(1.00 .0154 2.01 .0193 3.01 .0257 4.00 .0566 5.00 .0570 6.01 .0680 7.01 .0222
+ 8.03 .0023 9.02 .0036 10.05 .0043 11.07 .0037 12.07 .0010 12.97 .0005 13.99 .0014 14.99 .0022
+ 15.98 .0023 16.97 .0011 17.96 .0007 18.95 .0004 19.12 .0003 19.89 .0002 20.92 .0003 21.11 .0002
+ 21.92 .0002 22.91 .0002 23.88 .0002 24.92 .0002 25.89 .0003 26.88 .0003 27.84 .0001))
+
+ (fhf-ds2 '(1.00 .0204 2.02 .0234 3.03 .0132 4.04 .0416 5.05 .0425 6.04 .0258 7.06 .0086
+ 8.07 .0067 9.14 .0009 10.17 .0030 11.20 .0008 12.09 .0016 13.11 .0015 14.12 .0029 15.11 .0028
+ 16.11 .0011 17.11 .0006 18.09 .0003 19.13 .0004 19.29 .0002 20.10 .0002 21.13 .0002 21.29 .0002
+ 22.26 .0001 23.11 .0003 24.11 .0003 25.08 .0002 26.10 .0002 27.08 .0002 28.10 .0001 28.28 .0001))
+
+ (fhf-e2 '(1.00 .0097 1.99 .0146 3.00 .0159 4.00 .0246 5.02 .0137 6.06 .0177 7.02 .0017
+ 8.05 .0029 9.04 .0058 10.06 .0041 10.96 .0009 12.03 .0029 13.08 .0021 14.12 .0008 15.14 .0002
+ 16.11 .0002 26.90 .0001))
+
+ (fhf-f2 '(1.00 .0039 2.02 .0070 3.04 .0156 4.06 .0113 5.08 .0222 6.07 .0065 7.07 .0046
+ 8.12 .0018 9.13 .0081 10.13 .0014 11.17 .0012 12.17 .0014 13.21 .0007 13.98 .0005 14.24 .0003
+ 14.98 .0003 15.96 .0002 17.21 .0001 18.97 .0002 20.02 .0001 21.05 .0001))
+
+ (fhf-fs2 '(1.02 .0030 2.03 .0096 3.04 .0372 4.06 .0225 5.09 .0048 6.17 .0019 7.19 .0014
+ 8.20 .0014 9.19 .0023 10.22 .0008 11.09 .0003 12.23 .0006 13.25 .0004 14.25 .0002 15.14 .0001
+ 16.19 .0002 17.20 .0002 18.24 .0002 19.23 .0001 20.27 .0001 21.29 .0001 23.26 .0001))
+
+ (fhf-g2 '(1.03 .0067 2.02 .0055 3.06 .0282 5.01 .0043 5.20 .0033 6.05 .0006 7.09 .0009
+ 8.13 .0070 9.17 .0006 10.20 .0010 11.23 .0007 12.28 .0002 13.16 .0001 14.23 .0001))
+
+ (fhf-gs2 '(.99 .0029 2.02 .0054 3.01 .0149 4.03 .0101 5.03 .0047 6.02 .0035 7.02 .0028
+ 8.04 .0026 9.03 .0010 10.03 .0003 11.07 .0004 11.89 .0001 12.98 .0001 13.99 .0002))
+
+ (fhf-a2 '(.99 .0020 2.00 .0131 3.00 .0085 4.01 .0199 4.99 .0044 5.98 .0020 7.00 .0029
+ 8.01 .0009 9.02 .0010 9.99 .0007 10.94 .0003))
+
+ (fhf-as2 '(1.00 .0013 2.01 .0042 3.01 .0101 3.99 .0132 4.98 .0011 5.97 .0007 6.96 .0031
+ 7.99 .0009 9.10 .0003 9.99 .0003 10.92 .0002 11.88 .0002 12.85 .0001))
+
+ (fhf-b2 '(1.01 .0038 2.00 .0081 2.98 .0138 3.96 .0105 4.96 .0021 5.95 .0034 6.89 .0013
+ 7.91 .0006 8.86 .0005 9.87 .0001))
+
+ (fhf-c3 '(1.00 .0033 2.01 .0162 3.00 .0168 4.00 .0069 5.00 .0033 6.01 .0061 7.01 .0006
+ 8.01 .0003 8.98 .0003 9.97 .0002 10.98 .0001))
+
+ (fhf-cs3 '(1.01 .0161 2.01 .0404 3.01 .0208 4.02 .0039 5.02 .0013 6.02 .0041 7.02 .0019
+ 8.01 .0011 9.01 .0003))
+
+ (fhf-d3 '(1.01 .0238 2.01 .0582 3.02 .0679 4.02 .0022 5.03 .0081 6.03 .0024 7.03 .0012
+ 8.05 .0010 9.05 .0001 10.08 .0001))
+
+ (fhf-ds3 '(1.00 .0295 2.01 .0519 3.02 .0343 4.04 .0119 5.05 .0067 6.07 .0011 7.08 .0013
+ 8.09 .0004))
+
+ (fhf-e3 '(1.01 .0251 2.04 .0479 3.03 .0741 4.04 .0054 5.05 .0049 6.04 .0029 7.06 .0021
+ 8.10 .0006 9.11 .0004 10.10 .0002 11.13 .0002))
+
+ (fhf-f3 '(1.02 .0143 2.02 .0453 3.04 .0115 4.05 .0021 5.08 .0007 6.10 .0007 7.07 .0006
+ 8.04 .0001))
+
+ (fhf-fs3 '(1.01 .0220 2.03 .0843 3.04 .0119 4.06 .0062 5.09 .0022 6.12 .0016 7.14 .0003
+ 9.13 .0001))
+
+ (fhf-g3 '(1.02 .0145 2.03 .0700 3.03 .0010 5.13 .0013 6.14 .0007 7.14 .0002))
+
+ (fhf-gs3 '(1.02 .0273 2.03 .0703 3.04 .0176 4.07 .0073 5.08 .0021 6.09 .0004 7.09 .0002
+ 8.09 .0001))
+
+ (fhf-a3 '(1.00 .0529 2.02 .0982 3.02 .0066 4.04 .0034 5.05 .0029 6.04 .0003 7.03 .0002))
+
+ (fhf-as3 '(1.01 .0274 2.01 .0613 3.02 .0056 4.03 .0056 5.03 .0024 6.03 .0003))
+
+ (fhf-b3 '(1.01 .0468 2.01 .0884 3.01 .0246 4.02 .0058 5.03 .0016 6.03 .0005 7.02 .0002
+ 8.01 .0001))
+
+ (fhf-c4 '(1.01 .0972 2.01 .0455 3.02 .0442 4.03 .0073 5.03 .0017 6.03 .0005 7.04 .0008
+ 8.05 .0003 9.05 .0001))
+
+ (fhf-cs4 '(1.01 .1452 2.01 .0382 3.02 .0285 4.02 .0080 5.02 .0019 6.01 .0002 7.03 .0003
+ 8.04 .0002))
+
+ (fhf-d4 '(1.01 .1930 2.02 .0066 3.03 .0070 4.05 .0041 5.05 .0016 6.07 .0003))
+
+ (fhf-ds4 '(1.00 .1433 2.01 .0414 3.02 .0101 4.03 .0020 5.02 .0002 6.03 .0003 7.06 .0001))
+
+ (fhf-e4 '(1.00 .1373 2.01 .0256 3.01 .0164 4.02 .0026 5.02 .0014 6.02 .0004 7.03 .0002))
+
+ (fhf-f4 '(1.01 .1930 2.01 .0192 3.02 .0124 4.02 .0030 5.03 .0013 6.03 .0006 7.03 .0002))
+
+ (fhf-fs4 '(1.01 .2352 2.01 .0485 3.02 .0135 4.03 .0035 5.03 .0010 6.04 .0004))
+
+ (fhf-g4 '(1.01 .1991 2.03 .0655 3.04 .0065 4.04 .0015 5.06 .0006 6.07 .0002))
+
+ (fhf-gs4 '(1.01 .2177 2.02 .0422 3.03 .0038 4.05 .0014 5.06 .0006))
+
+ (fhf-a4 '(1.01 .3779 2.02 .0161 3.03 .0026 4.04 .0009 5.05 .0005))
+
+ (fhf-as4 '(1.00 .1879 2.01 .0205 3.02 .0006 4.03 .0006))
+
+ (fhf-b4 '(.99 .2910 1.99 .0363 2.99 .0019 3.99 .0001 4.98 .0001))
+
+ (fhf-c5 '(1.00 .0690 2.01 .0086 3.01 .0002 4.00 .0002))
+
+ (fhf-cs5 '(1.01 .0872 2.02 .0247 3.03 .0008 4.05 .0002))
+
+ (fhf-d5 '(1.01 .0213 2.02 .0275 3.03 .0031 4.04 .0008 5.05 .0002 6.07 .0001))
+
+ (fhf-ds5 '(1.01 .1852 2.01 .0224 3.01 .0043 4.02 .0006 5.03 .0001))
+
+ (fhf-e5 '(1.01 .1063 2.02 .0144 3.03 .0018 4.04 .0006 5.05 .0001))
+
+ (fhf-f5 '(1.02 .1058 2.04 .0062 3.06 .0023 4.08 .0005))
+
+ (fhf-fs5 '(1.01 .1683 2.03 .0099 3.04 .0026 4.05 .0004 5.07 .0003))
+
+ (fhf-g5 '(1.01 .3271 2.02 .0090 3.03 .0022 4.04 .0007))
+
+
+ ;; flute?
+ (fl-c4 '(1.01 .0602 2.02 .0954 3.03 .0270 4.03 .0199 5.05 .0177 6.06 .0104 7.07 .0040
+ 8.08 .0040 9.08 .0035 10.10 .0017 11.10 .0009 12.12 .0004 13.11 .0002 14.13 .0006 15.14 .0003
+ 17.15 .0002 18.16 .0001))
+
+ (fl-cs4 '(1.01 .0672 2.01 .0689 3.02 .0604 4.02 .0410 5.02 .0130 6.03 .0040 7.03 .0210
+ 8.03 .0078 9.04 .0010 10.07 .0002 11.05 .0005 12.05 .0008 13.05 .0004 14.06 .0002 15.07 .0001
+ 19.08 .0001))
+
+ (fl-d4 '(1.01 .0747 2.01 .2106 3.01 .0522 4.02 .0208 5.01 .0138 6.02 .0024 7.03 .0071
+ 8.03 .0038 8.17 .0002 8.74 .0001 10.03 .0004 11.04 .0014 12.03 .0001 13.06 .0002 14.05 .0003
+ 15.06 .0001 16.07 .0001 17.06 .0002 18.06 .0002))
+
+ (fl-ds4 '(1.00 .0256 2.00 .1167 3.00 .0241 4.01 .0159 5.01 .0200 6.00 .0167 7.01 .0069
+ 8.04 .0004 9.00 .0009 10.01 .0010 11.00 .0004 12.00 .0003 13.00 .0002 14.01 .0002 16.00 .0002
+ 17.01 .0002))
+
+ (fl-e4 '(1.00 .0572 2.01 .1769 3.01 .0622 4.00 .0323 5.01 .0210 6.01 .0163 7.02 .0068
+ 8.01 .0007 8.13 .0002 8.39 .0001 10.02 .0011 11.02 .0004 12.02 .0003 15.03 .0002 16.03 .0001
+ 17.04 .0001 18.04 .0001))
+
+ (fl-f4 '(1.01 .0438 2.01 .0964 3.01 .0569 4.01 .0096 5.01 .0164 6.01 .0194 7.02 .0024
+ 8.01 .0005 9.03 .0007 10.04 .0005 12.05 .0002 13.04 .0001 14.05 .0002))
+
+ (fl-fs4 '(1.00 .0952 2.00 .1432 3.01 .0299 4.01 .0371 5.02 .0189 6.02 .0092 7.03 .0060
+ 8.03 .0003 9.04 .0025 10.04 .0006 11.04 .0003 13.05 .0002 14.06 .0002))
+
+ (fl-g4 '(1.00 .2831 2.01 .1781 3.01 .0370 4.02 .0191 5.02 .0313 6.02 .0048 7.04 .0007
+ 8.03 .0022 9.04 .0015 9.13 .0001 10.04 .0001 11.05 .0002 12.05 .0002 14.07 .0001 15.06 .0001))
+
+ (fl-gs4 '(1.00 .2598 2.00 .2241 3.01 .0407 4.01 .0354 5.01 .0398 6.01 .0111 7.03 .0007
+ 8.01 .0030 9.01 .0018 10.02 .0002 12.02 .0004 13.02 .0001 14.03 .0002 15.03 .0001))
+
+ (fl-a4 '(1.00 .2580 2.01 .1605 3.00 .0236 4.01 .0281 5.02 .0047 6.02 .0024 7.02 .0010
+ 8.02 .0027 9.02 .0004 10.03 .0002 11.03 .0003 12.04 .0001 13.04 .0002 14.04 .0002))
+
+ (fl-as4 '(1.01 .1855 2.01 .1041 3.01 .0480 4.02 .0416 5.02 .0059 6.02 .0016 7.03 .0004
+ 8.03 .0016 9.03 .0003 10.04 .0004 11.05 .0003 16.07 .0002))
+
+ (fl-b4 '(1.01 .0564 2.01 .1996 3.02 .0219 4.02 .0108 5.03 .0183 6.04 .0005 7.04 .0009
+ 8.05 .0014 10.06 .0006 11.07 .0003))
+
+ (fl-c5 '(1.01 .0245 2.02 .1674 3.04 .0228 4.05 .0229 5.06 .0087 6.09 .0004 7.09 .0004
+ 8.10 .0003 9.11 .0002 10.14 .0002 11.15 .0001))
+
+ (fl-cs5 '(1.00 .0885 2.01 .0661 3.01 .0281 4.02 .0068 5.02 .0038 6.02 .0010 7.02 .0008
+ 8.03 .0007 9.03 .0005 10.04 .0002 11.04 .0003))
+
+ (fl-d5 '(1.01 .3830 2.01 .1043 3.01 .0372 4.02 .0175 5.03 .0035 6.03 .0011 7.04 .0010
+ 8.04 .0004 9.04 .0002 10.05 .0001))
+
+ (fl-ds5 '(1.00 .2294 2.01 .0606 3.01 .0238 4.01 .0050 5.01 .0041 6.02 .0007 7.02 .0007
+ 8.02 .0006 10.03 .0002 12.03 .0001))
+
+ (fl-e5 '(1.01 .3759 2.03 .0529 3.03 .0595 4.05 .0010 5.06 .0077 6.07 .0008 7.09 .0007
+ 8.09 .0005 9.11 .0001 10.12 .0002 12.14 .0001))
+
+ (fl-f5 '(1.01 .1982 2.02 .0204 3.02 .0554 4.03 .0064 5.04 .0040 6.05 .0016 7.06 .0007
+ 8.07 .0006 9.07 .0001 10.08 .0001 12.10 .0001))
+
+ (fl-fs5 '(1.01 .3241 2.02 .0548 3.03 .0082 4.04 .0022 5.05 .0038 6.06 .0004 7.07 .0009
+ 8.09 .0001 9.09 .0003 10.10 .0001))
+
+ (fl-g5 '(1.01 .4049 2.01 .0301 3.02 .0229 4.03 .0047 5.04 .0029 6.05 .0014 7.05 .0009
+ 8.06 .0003 9.07 .0002 10.07 .0002 11.09 .0001 12.09 .0001))
+
+ (fl-gs5 '(1.00 .5433 2.01 .0536 3.01 .0411 4.02 .0074 5.02 .0014 6.02 .0011 7.03 .0004
+ 8.03 .0003 9.04 .0001))
+
+ (fl-a5 '(1.01 .3063 2.01 .0346 3.02 .0102 4.03 .0031 5.03 .0007 6.04 .0010 7.03 .0003
+ 8.06 .0001 9.05 .0002 11.06 .0002))
+
+ (fl-as5 '(1.01 .1962 2.03 .0355 3.04 .0128 4.06 .0020 5.07 .0021 6.08 .0003 7.10 .0003
+ 8.11 .0002))
+
+ (fl-b5 '(1.01 .3829 2.02 .0120 3.03 .0037 4.04 .0030 5.05 .0016 6.06 .0006 7.07 .0002
+ 8.08 .0004 9.09 .0001))
+
+ (fl-c6 '(1.01 .3072 2.02 .0248 3.04 .0012 4.05 .0006 5.06 .0011 6.07 .0009 7.08 .0003
+ 8.10 .0001 10.12 .0001))
+
+ (fl-cs6 '(1.01 .1262 2.02 .0030 3.03 .0012 4.04 .0005 5.06 .0010 6.07 .0002 7.08 .0004
+ 8.09 .0002))
+
+ (fl-d6 '(1.01 .3050 2.03 .0071 3.04 .0107 4.06 .0005 5.07 .0015 6.08 .0002 7.10 .0003
+ 8.11 .0002 9.13 .0001))
+
+ (fl-ds6 '(1.02 .0954 2.05 .0025 3.06 .0047 4.09 .0007 5.11 .0017 6.13 .0001 7.15 .0002))
+
+ (fl-e6 '(1.02 .2864 2.05 .0057 3.08 .0023 5.13 .0007 6.16 .0001 8.21 .0001))
+
+ (fl-f6 '(1.03 .0675 2.05 .0049 3.08 .0024 5.13 .0008 6.16 .0002 7.18 .0002 8.21 .0001))
+
+ (fl-fs6 '(1.02 .2553 2.05 .0044 3.07 .0032 5.12 .0007 6.14 .0002 8.19 .0001))
+
+ (fl-g6 '(1.02 .1190 2.05 .0069 3.07 .0046 5.12 .0010 6.14 .0001 7.17 .0007 7.26 .0001))
+
+ (fl-gs6 '(1.02 .3872 2.05 .0093 3.07 .0051 5.12 .0008 6.15 .0001 7.17 .0002 7.18 .0001))
+
+ (fl-a6 '(1.02 .2920 2.04 .0122 3.06 .0052 4.08 .0007 5.10 .0003 6.31 .0002 7.15 .0003))
+
+ (fl-as6 '(1.02 .5687 2.04 .0090 3.06 .0075 4.08 .0007 5.10 .0010 6.15 .0002 6.21 .0002
+ 6.40 .0001 6.47 .0001))
+
+ (fl-b6 '(1.03 .2752 2.06 .0061 3.09 .0039 5.14 .0002 5.86 .0002 6.18 .0001 6.24 .0001
+ 6.45 .0001))
+
+ (fl-c7 '(1.04 .2720 2.07 .0046 5.18 .0003 5.40 .0002 6.02 .0002))
+
+ (fl-cs7 '(1.03 .3752 2.06 .0156 5.16 .0007 5.20 .0003 5.40 .0001 5.41 .0001 5.57 .0001))
+
+ (fl-d7 '(1.04 .2861 2.07 .0147 5.18 .0012 5.27 .0002 5.30 .0001))
+
+ ;; oboe?
+ (ob-as3 '(1.00 .0504 2.00 .0724 2.99 .1036 3.99 .1215 4.99 .1360 5.99 .0852 6.98 .0593
+ 7.97 .0230 8.98 .0077 9.97 .0063 10.97 .0016 11.96 .0008 12.97 .0017 13.97 .0017 14.96 .0020
+ 15.96 .0007 16.96 .0006 17.96 .0002 21.95 .0001 22.95 .0001 23.94 .0002 24.94 .0002 25.94 .0001))
+
+ (ob-b3 '(.99 .0587 1.99 .0820 2.98 .0673 3.98 .1069 4.97 .1336 5.97 .0948 6.96 .0455
+ 7.96 .0070 8.95 .0017 9.95 .0023 10.95 .0063 11.93 .0031 12.93 .0021 13.92 .0009 14.92 .0005
+ 15.92 .0003 16.89 .0001 21.88 .0001 23.88 .0001))
+
+ (ob-c4 '(1.00 .0784 2.00 .0494 2.99 .0668 3.99 .0785 4.99 .1406 5.99 .0747 6.99 .0460
+ 7.98 .0147 8.98 .0115 9.97 .0083 10.98 .0058 11.98 .0059 12.97 .0027 13.98 .0010 14.96 .0006
+ 15.97 .0002 16.96 .0001 17.96 .0002 19.95 .0001 20.96 .0002 21.95 .0001))
+
+ (ob-cs4 '(1.00 .0801 2.00 .0526 2.99 .0568 3.99 .0713 4.99 .1811 5.99 .0721 6.99 .0491
+ 7.98 .0201 8.98 .0128 9.98 .0132 10.98 .0104 11.98 .0081 12.97 .0055 13.97 .0026 14.97 .0010
+ 15.97 .0003 16.97 .0004 17.96 .0003 18.97 .0004 19.95 .0006 20.96 .0003 21.96 .0002))
+
+ (ob-d4 '(1.00 .0775 2.00 .0853 3.01 .0538 4.01 .0600 5.00 .1853 6.01 .0714 7.01 .0247
+ 8.01 .0265 9.01 .0028 10.01 .0116 11.02 .0078 12.02 .0060 13.01 .0036 14.02 .0010 15.03 .0005
+ 16.01 .0002 17.02 .0002 18.01 .0004 19.02 .0004 20.02 .0002 21.02 .0001))
+
+ (ob-ds4 '(1.00 .0922 1.99 .0922 2.99 .0912 3.99 .0337 4.98 .1696 5.97 .0481 6.98 .0184
+ 7.97 .0104 8.96 .0185 9.96 .0147 10.96 .0057 11.95 .0039 12.95 .0012 13.94 .0006 14.94 .0009
+ 15.94 .0005 16.93 .0005 17.93 .0003 18.93 .0001 19.92 .0001))
+
+ (ob-e4 '(1.00 .0970 2.01 .0554 3.01 .0624 4.02 .1806 5.02 .1392 6.02 .0367 7.03 .0165
+ 8.04 .0102 9.04 .0159 10.04 .0077 11.04 .0092 12.05 .0027 13.06 .0004 14.06 .0007 15.06 .0003
+ 16.07 .0006 17.07 .0003 18.08 .0003 19.08 .0001 20.09 .0002))
+
+ (ob-f4 '(1.00 .0988 2.01 .0364 3.00 .0573 4.01 .2291 5.01 .0802 6.02 .0188 7.02 .0160
+ 8.02 .0143 9.02 .0152 10.02 .0140 11.03 .0054 12.01 .0003 13.03 .0012 14.03 .0008 15.04 .0008
+ 16.04 .0006 17.04 .0006 18.04 .0003 19.05 .0001))
+
+ (ob-fs4 '(1.01 .0340 2.01 .0618 3.02 .0923 4.03 .1479 5.03 .1058 6.04 .0281 7.05 .0071
+ 8.05 .0157 9.06 .0018 10.07 .0014 11.07 .0005 12.08 .0013 13.09 .0012 14.10 .0005 15.10 .0003
+ 16.11 .0005 17.12 .0002))
+
+ (ob-g4 '(1.01 .0606 2.01 .0774 3.02 .0552 4.03 .0700 5.04 .0194 6.04 .0066 7.05 .0147
+ 8.06 .0134 9.07 .0055 10.08 .0035 11.08 .0004 12.10 .0004 13.10 .0008 14.11 .0011 15.10 .0004))
+
+ (ob-gs4 '(1.01 .0573 2.01 .0346 3.03 .0608 4.03 .0675 5.04 .0643 6.05 .0193 7.06 .0125
+ 8.07 .0109 9.07 .0010 10.09 .0003 11.09 .0016 12.10 .0015 13.11 .0006 14.11 .0003 15.13 .0002
+ 16.13 .0002))
+
+ (ob-a4 '(1.00 .0923 2.00 .0358 3.00 .0726 4.00 .2111 5.00 .0316 5.99 .0016 7.00 .0080
+ 8.00 .0075 9.00 .0031 10.01 .0007 11.01 .0008 12.00 .0005 13.00 .0003 14.01 .0005 15.01 .0001))
+
+ (ob-as4 '(1.00 .0753 2.00 .0693 3.00 .3731 4.01 .0810 5.01 .0245 6.00 .0142 7.00 .0061
+ 8.01 .0025 9.01 .0004 10.01 .0005 11.01 .0005 12.02 .0005 13.02 .0003))
+
+ (ob-b4 '(1.00 .0618 2.01 .0377 3.02 .0642 4.02 .0401 5.02 .0165 6.03 .0176 7.03 .0079
+ 8.04 .0016 9.04 .0003 10.06 .0003 11.05 .0006 12.06 .0003 13.06 .0001))
+
+ (ob-c5 '(1.01 .0484 2.02 .0490 3.02 .0364 4.03 .0166 5.03 .0172 6.04 .0261 7.05 .0120
+ 8.06 .0021 9.06 .0035 10.07 .0021 11.08 .0008 12.08 .0003))
+
+ (ob-cs5 '(1.01 .1071 2.02 .0487 3.03 .1175 4.04 .0329 5.05 .0231 6.06 .0136 7.07 .0047
+ 8.07 .0009 9.09 .0011 10.10 .0016 11.10 .0010 12.12 .0002))
+
+ (ob-d5 '(1.01 .1893 2.01 .0986 3.02 .1665 4.02 .0326 5.03 .0275 6.04 .0155 7.04 .0029
+ 8.05 .0013 9.06 .0016 10.07 .0010 11.07 .0004 12.08 .0001))
+
+ (ob-ds5 '(1.00 .2003 2.00 .0265 3.00 .1047 4.00 .0138 5.00 .0391 6.00 .0094 6.99 .0023
+ 8.00 .0018 8.99 .0011 9.99 .0006 10.99 .0002 11.99 .0001))
+
+ (ob-e5 '(1.00 .0906 2.00 .4215 3.00 .1046 3.99 .0081 4.99 .0118 5.99 .0054 6.99 .0005
+ 7.99 .0014 8.99 .0005 9.99 .0002))
+
+ (ob-f5 '(1.00 .0657 2.00 .4134 2.99 .0463 3.99 .0144 4.99 .0277 5.99 .0047 6.98 .0005
+ 7.98 .0004 8.98 .0003))
+
+ (ob-fs5 '(1.01 .0957 2.03 .2943 3.04 .0855 4.06 .0568 5.07 .0247 6.08 .0013 7.10 .0024
+ 8.12 .0011 9.13 .0006 10.15 .0002 11.16 .0001 12.17 .0001))
+
+ (ob-g5 '(1.01 .0975 2.02 .1012 3.04 .0543 4.05 .0298 5.06 .0083 6.07 .0026 7.08 .0017
+ 8.09 .0003 9.11 .0001))
+
+ (ob-gs5 '(1.01 .0400 2.01 .0481 3.02 .0403 4.02 .0169 5.03 .0002 6.04 .0030 7.04 .0008))
+
+ (ob-a5 '(1.01 .0725 2.02 .1474 3.03 .0327 4.04 .0281 5.05 .0013 6.06 .0028 7.07 .0004))
+
+ (ob-as5 '(1.00 .0837 2.00 .1039 3.00 .0366 4.01 .0118 5.01 .0021 6.01 .0012))
+
+ (ob-b5 '(1.02 .0812 2.04 .0709 3.06 .0658 4.08 .0099 5.10 .0069 6.12 .0007 7.14 .0001
+ 8.16 .0001))
+
+ (ob-c6 '(1.01 .0799 2.02 .0161 3.02 .0476 4.03 .0084 5.04 .0029 6.05 .0002))
+
+ (ob-cs6 '(1.01 .2331 2.02 .1151 3.03 .0163 4.04 .0013 5.05 .0004 6.07 .0003))
+
+ (ob-d6 '(1.02 .2469 2.03 .0288 3.05 .0144 4.06 .0012 5.08 .0008))
+
+ (ob-ds6 '(1.00 .2770 2.00 .0028 3.00 .0095 4.00 .0042 5.00 .0006 5.99 .0002))
+
+ (ob-e6 '(1.00 .3019 2.01 .0125 3.01 .0049 4.02 .0008 5.02 .0001 6.02 .0001))
+
+ (ob-f6 '(1.01 .0898 2.01 .0089 3.02 .0067 4.02 .0010 5.03 .0002 6.03 .0001))
+
+ (ob-fs6 '(1.01 .1330 2.03 .0090 3.05 .0031 4.06 .0001))
+
+ (ob-g6 '(1.00 .1046 1.99 .0228 2.99 .0004 3.98 .0001))
+
+
+ ;; piano
+ (p-c1 '(1.97 .0326 2.99 .0086 3.95 .0163 4.97 .0178 5.98 .0177 6.95 .0315 8.02 .0001
+ 8.94 .0076 9.96 .0134 10.99 .0284 11.98 .0229 13.02 .0229 13.89 .0010 15.06 .0090 16.00 .0003
+ 17.08 .0078 18.16 .0064 19.18 .0129 20.21 .0085 21.27 .0225 22.32 .0061 23.41 .0102 24.48 .0005
+ 25.56 .0016 26.64 .0018 27.70 .0113 28.80 .0111 29.91 .0158 31.06 .0093 32.17 .0017 33.32 .0002
+ 34.42 .0018 35.59 .0027 36.74 .0055 37.90 .0037 39.06 .0064 40.25 .0033 41.47 .0014 42.53 .0004
+ 43.89 .0010 45.12 .0039 46.33 .0039 47.64 .0009 48.88 .0016 50.13 .0006 51.37 .0010 52.70 .0002
+ 54.00 .0004 55.30 .0008 56.60 .0025 57.96 .0010 59.30 .0012 60.67 .0011 61.99 .0003 62.86 .0001
+ 64.36 .0005 64.86 .0001 66.26 .0004 67.70 .0006 68.94 .0002 70.10 .0001 70.58 .0002 72.01 .0007
+ 73.53 .0006 75.00 .0002 77.03 .0005 78.00 .0002 79.57 .0006 81.16 .0005 82.70 .0005 84.22 .0003
+ 85.41 .0002 87.46 .0001 90.30 .0001 94.02 .0001 95.26 .0002 109.39 .0003))
+
+ (p-cs1 '(1.98 .0194 2.99 .0210 3.97 .0276 4.96 .0297 5.96 .0158 6.99 .0207 8.01 .0009
+ 9.00 .0101 10.00 .0297 11.01 .0289 12.02 .0211 13.04 .0127 14.07 .0061 15.08 .0174 16.13 .0009
+ 17.12 .0093 18.16 .0117 19.21 .0122 20.29 .0108 21.30 .0077 22.38 .0132 23.46 .0073 24.14 .0002
+ 25.58 .0026 26.69 .0035 27.77 .0053 28.88 .0024 30.08 .0027 31.13 .0075 32.24 .0027 33.36 .0004
+ 34.42 .0004 35.64 .0019 36.78 .0037 38.10 .0009 39.11 .0027 40.32 .0010 41.51 .0013 42.66 .0019
+ 43.87 .0007 45.13 .0017 46.35 .0019 47.65 .0021 48.89 .0014 50.18 .0023 51.42 .0015 52.73 .0002
+ 54.00 .0005 55.34 .0006 56.60 .0010 57.96 .0016 58.86 .0005 59.30 .0004 60.75 .0005 62.22 .0003
+ 63.55 .0005 64.82 .0003 66.24 .0003 67.63 .0011 69.09 .0007 70.52 .0004 72.00 .0005 73.50 .0008
+ 74.95 .0003 77.13 .0013 78.02 .0002 79.48 .0004 82.59 .0004 84.10 .0003))
+
+ (p-d1 '(2.00 .0313 2.99 .0109 4.00 .0215 5.00 .0242 5.98 .0355 7.01 .0132 8.01 .0009
+ 9.01 .0071 10.00 .0258 11.03 .0221 12.02 .0056 13.06 .0196 14.05 .0160 15.11 .0107 16.11 .0003
+ 17.14 .0111 18.21 .0085 19.23 .0010 20.28 .0048 21.31 .0128 22.36 .0051 23.41 .0041 24.05 .0006
+ 25.54 .0019 26.62 .0028 27.72 .0034 28.82 .0062 29.89 .0039 30.98 .0058 32.08 .0011 33.21 .0002
+ 34.37 .0008 35.46 .0018 36.62 .0036 37.77 .0018 38.92 .0042 40.07 .0037 41.23 .0011 42.67 .0003
+ 43.65 .0018 44.68 .0025 45.99 .0044 47.21 .0051 48.40 .0044 49.67 .0005 50.88 .0019 52.15 .0003
+ 53.42 .0008 54.69 .0010 55.98 .0005 57.26 .0013 58.53 .0027 59.83 .0011 61.21 .0027 62.54 .0003
+ 63.78 .0003 65.20 .0001 66.60 .0006 67.98 .0008 69.37 .0019 70.73 .0007 72.14 .0004 73.62 .0002
+ 74.40 .0003 76.52 .0006 77.97 .0002 79.49 .0004 80.77 .0003 81.00 .0001 82.47 .0005 83.97 .0001
+ 87.27 .0002))
+
+ (p-ds1 '(2.00 .0257 2.99 .0142 3.97 .0202 4.95 .0148 5.95 .0420 6.95 .0037 7.94 .0004
+ 8.94 .0172 9.95 .0191 10.96 .0115 11.97 .0059 12.98 .0140 14.00 .0178 15.03 .0121 16.09 .0002
+ 17.07 .0066 18.08 .0033 19.15 .0022 20.18 .0057 21.22 .0077 22.29 .0037 23.33 .0066 24.97 .0002
+ 25.49 .0019 26.55 .0042 27.61 .0043 28.73 .0038 29.81 .0084 30.91 .0040 32.03 .0025 33.14 .0005
+ 34.26 .0003 35.38 .0019 36.56 .0037 37.68 .0049 38.86 .0036 40.11 .0011 41.28 .0008 42.50 .0004
+ 43.60 .0002 44.74 .0022 45.99 .0050 47.20 .0009 48.40 .0036 49.68 .0004 50.92 .0009 52.17 .0005
+ 53.46 .0007 54.76 .0006 56.06 .0005 57.34 .0011 58.67 .0005 59.95 .0015 61.37 .0008 62.72 .0004
+ 65.42 .0009 66.96 .0003 68.18 .0003 69.78 .0003 71.21 .0004 72.45 .0002 74.22 .0003 75.44 .0001
+ 76.53 .0003 78.31 .0004 79.83 .0003 80.16 .0001 81.33 .0003 82.44 .0001 83.17 .0002 84.81 .0003
+ 85.97 .0003 89.08 .0001 90.70 .0002 92.30 .0002 95.59 .0002 97.22 .0003 98.86 .0001 108.37 .0001
+ 125.54 .0001))
+
+ (p-e1 '(1.99 .0650 3.03 .0040 4.03 .0059 5.02 .0090 5.97 .0227 6.98 .0050 8.04 .0020
+ 9.00 .0082 9.96 .0078 11.01 .0056 12.01 .0095 13.02 .0050 14.04 .0093 15.08 .0064 16.14 .0017
+ 17.06 .0020 18.10 .0025 19.14 .0023 20.18 .0015 21.24 .0032 22.29 .0029 23.32 .0014 24.37 .0005
+ 25.43 .0030 26.50 .0022 27.60 .0027 28.64 .0024 29.76 .0035 30.81 .0136 31.96 .0025 33.02 .0003
+ 34.13 .0005 35.25 .0007 36.40 .0014 37.51 .0020 38.64 .0012 39.80 .0019 40.97 .0004 42.09 .0003
+ 43.24 .0003 44.48 .0002 45.65 .0024 46.86 .0005 48.07 .0013 49.27 .0008 50.49 .0006 52.95 .0001
+ 54.23 .0005 55.45 .0004 56.73 .0001 58.03 .0003 59.29 .0002 60.59 .0003 62.04 .0002 65.89 .0002
+ 67.23 .0002 68.61 .0002 69.97 .0004 71.36 .0005 85.42 .0001))
+
+ (p-f1 '(1.98 .0256 2.96 .0158 3.95 .0310 4.94 .0411 5.95 .0238 6.94 .0152 7.93 .0011
+ 8.95 .0185 9.92 .0166 10.93 .0306 11.94 .0258 12.96 .0202 13.97 .0403 14.95 .0228 15.93 .0005
+ 17.01 .0072 18.02 .0034 19.06 .0028 20.08 .0124 21.13 .0137 22.16 .0102 23.19 .0058 23.90 .0013
+ 25.30 .0039 26.36 .0039 27.41 .0025 28.47 .0071 29.64 .0031 30.60 .0027 31.71 .0021 32.84 .0003
+ 33.82 .0002 35.07 .0019 36.09 .0054 37.20 .0038 38.33 .0024 39.47 .0055 40.55 .0016 41.77 .0006
+ 42.95 .0002 43.27 .0018 44.03 .0006 45.25 .0019 46.36 .0033 47.50 .0024 48.87 .0012 50.03 .0016
+ 51.09 .0004 53.52 .0017 54.74 .0012 56.17 .0003 57.40 .0011 58.42 .0020 59.70 .0007 61.29 .0008
+ 62.56 .0003 63.48 .0002 64.83 .0002 66.12 .0012 67.46 .0017 68.81 .0003 69.13 .0003 70.53 .0002
+ 71.84 .0001 73.28 .0002 75.52 .0010 76.96 .0005 77.93 .0003 78.32 .0003 79.73 .0003 81.69 .0002
+ 82.52 .0001 84.01 .0001 84.61 .0002 86.88 .0001 88.36 .0002 89.85 .0002 91.35 .0003 92.86 .0002
+ 93.40 .0001 105.28 .0002 106.22 .0002 107.45 .0001 108.70 .0003 122.08 .0002))
+
+ (p-fs1 '(1.97 .0264 2.97 .0211 3.98 .0234 4.98 .0307 5.96 .0085 6.94 .0140 7.93 .0005
+ 8.96 .0112 9.96 .0209 10.98 .0194 11.98 .0154 12.99 .0274 13.99 .0127 15.01 .0101 15.99 .0002
+ 17.04 .0011 18.08 .0032 19.14 .0028 20.12 .0054 21.20 .0053 22.13 .0028 23.22 .0030 24.32 .0006
+ 25.24 .0004 26.43 .0028 27.53 .0048 28.52 .0039 29.54 .0047 30.73 .0044 31.82 .0007 32.94 .0008
+ 34.04 .0012 35.13 .0018 36.29 .0007 37.35 .0075 38.51 .0045 39.66 .0014 40.90 .0004 41.90 .0002
+ 43.08 .0002 44.24 .0017 45.36 .0013 46.68 .0020 47.79 .0015 48.98 .0010 50.21 .0012 51.34 .0001
+ 53.82 .0003 55.09 .0004 56.23 .0005 57.53 .0004 58.79 .0005 59.30 .0002 60.03 .0002 61.40 .0003
+ 62.84 .0001 66.64 .0001 67.97 .0001 69.33 .0001 70.68 .0001 73.57 .0002 75.76 .0002 76.45 .0001
+ 79.27 .0001 80.44 .0002 81.87 .0002))
+
+ (p-g1 '(2.00 .0311 2.99 .0086 3.99 .0266 4.97 .0123 5.98 .0235 6.97 .0161 7.97 .0008
+ 8.96 .0088 9.96 .0621 10.99 .0080 11.99 .0034 12.99 .0300 14.03 .0228 15.04 .0105 16.03 .0004
+ 17.06 .0036 18.09 .0094 18.95 .0009 20.17 .0071 21.21 .0161 22.25 .0106 23.28 .0104 24.33 .0008
+ 25.38 .0030 26.46 .0035 27.50 .0026 28.59 .0028 29.66 .0128 30.75 .0139 31.81 .0038 32.93 .0006
+ 34.04 .0004 35.16 .0005 36.25 .0023 37.35 .0012 38.46 .0021 39.59 .0035 40.71 .0006 41.86 .0007
+ 42.42 .0001 43.46 .0003 44.17 .0032 45.29 .0013 46.57 .0004 47.72 .0011 48.79 .0005 50.11 .0005
+ 51.29 .0003 52.47 .0002 53.68 .0004 55.02 .0005 56.18 .0003 57.41 .0003 58.75 .0007 59.33 .0009
+ 60.00 .0004 61.34 .0001 64.97 .0003 65.20 .0002 66.48 .0002 67.83 .0002 68.90 .0003 70.25 .0003
+ 71.59 .0002 73.68 .0001 75.92 .0001 77.08 .0002 78.45 .0002 81.56 .0002 82.99 .0001 88.39 .0001))
+
+ (p-gs1 '(.97 .0059 1.98 .0212 2.99 .0153 3.99 .0227 4.96 .0215 5.97 .0153 6.98 .0085
+ 7.98 .0007 8.97 .0179 9.98 .0512 10.98 .0322 12.00 .0098 13.02 .0186 14.00 .0099 15.05 .0109
+ 15.88 .0011 17.07 .0076 18.11 .0071 19.12 .0045 20.16 .0038 21.23 .0213 22.27 .0332 23.34 .0082
+ 24.34 .0014 25.42 .0024 26.47 .0012 27.54 .0014 28.60 .0024 29.72 .0026 30.10 .0008 31.91 .0021
+ 32.13 .0011 33.02 .0007 34.09 .0014 35.17 .0007 36.27 .0024 37.39 .0029 38.58 .0014 39.65 .0017
+ 40.95 .0012 41.97 .0004 42.43 .0002 43.49 .0001 44.31 .0012 45.42 .0031 46.62 .0017 47.82 .0013
+ 49.14 .0013 50.18 .0010 51.54 .0003 53.90 .0006 55.06 .0010 56.31 .0003 57.63 .0001 59.02 .0003
+ 60.09 .0004 60.35 .0004 61.62 .0009 63.97 .0001 65.19 .0001 65.54 .0002 66.92 .0002 67.94 .0002
+ 69.17 .0003 69.60 .0004 70.88 .0002 72.24 .0002 76.12 .0001 78.94 .0001 81.75 .0001 82.06 .0001
+ 83.53 .0001 90.29 .0002 91.75 .0001 92.09 .0002 93.28 .0001 97.07 .0001))
+
+ (p-a1 '(1.98 .0159 2.98 .1008 3.98 .0365 4.98 .0133 5.97 .0101 6.97 .0115 7.97 .0007
+ 8.99 .0349 10.01 .0342 11.01 .0236 12.00 .0041 13.02 .0114 14.05 .0137 15.06 .0100 16.05 .0007
+ 17.04 .0009 18.12 .0077 19.15 .0023 20.12 .0017 21.24 .0113 22.26 .0126 23.30 .0093 24.36 .0007
+ 25.43 .0007 26.47 .0009 27.55 .0013 28.59 .0025 29.61 .0010 30.77 .0021 31.86 .0023 32.96 .0003
+ 34.03 .0007 35.06 .0005 36.20 .0006 37.34 .0006 38.36 .0009 39.60 .0016 40.69 .0005 41.77 .0002
+ 42.92 .0002 44.02 .0003 45.24 .0006 46.33 .0004 47.50 .0007 48.71 .0007 49.87 .0002 51.27 .0002
+ 53.42 .0003 55.88 .0003 57.10 .0004 58.34 .0002 59.86 .0003 61.13 .0003 67.18 .0001 68.50 .0001
+ 71.17 .0001 83.91 .0001 90.55 .0001))
+
+ (p-as1 '(.98 .0099 2.00 .0181 2.99 .0353 3.98 .0285 4.97 .0514 5.96 .0402 6.96 .0015
+ 7.98 .0012 8.98 .0175 9.98 .0264 10.98 .0392 11.98 .0236 13.00 .0153 14.04 .0049 15.00 .0089
+ 16.01 .0001 17.03 .0106 18.03 .0028 19.05 .0024 20.08 .0040 21.11 .0103 22.12 .0104 23.20 .0017
+ 24.19 .0008 25.20 .0007 26.24 .0011 27.36 .0009 27.97 .0030 29.40 .0044 30.37 .0019 31.59 .0017
+ 32.65 .0008 33.59 .0005 34.79 .0009 35.75 .0027 36.88 .0035 37.93 .0039 39.00 .0031 40.08 .0025
+ 41.16 .0010 43.25 .0004 44.52 .0012 45.62 .0023 45.85 .0012 47.00 .0006 47.87 .0008 48.99 .0003
+ 50.48 .0003 51.62 .0001 52.43 .0001 53.56 .0002 54.76 .0002 56.04 .0002 56.68 .0006 57.10 .0003
+ 58.28 .0005 59.47 .0003 59.96 .0002 60.67 .0001 63.08 .0002 64.29 .0002 66.72 .0001 67.97 .0001
+ 68.65 .0001 70.43 .0001 79.38 .0001 80.39 .0001 82.39 .0001))
+
+ (p-b1 '(1.00 .0765 1.99 .0151 2.99 .0500 3.99 .0197 5.00 .0260 6.00 .0145 6.98 .0128
+ 7.97 .0004 8.98 .0158 9.99 .0265 11.02 .0290 12.02 .0053 13.03 .0242 14.03 .0103 15.06 .0054
+ 16.04 .0006 17.08 .0008 18.10 .0058 19.16 .0011 20.16 .0055 21.18 .0040 22.20 .0019 23.22 .0014
+ 24.05 .0005 25.31 .0019 26.38 .0018 27.44 .0022 28.45 .0024 29.57 .0073 30.58 .0032 31.66 .0071
+ 32.73 .0015 33.85 .0005 34.96 .0003 36.00 .0020 37.11 .0018 38.18 .0055 39.23 .0006 40.33 .0004
+ 41.52 .0003 43.41 .0028 45.05 .0003 45.99 .0002 47.07 .0003 48.52 .0002 49.48 .0003 50.63 .0003
+ 51.81 .0002 54.05 .0002 55.24 .0001 56.62 .0001 57.81 .0004 59.16 .0013 60.23 .0003 66.44 .0001
+ 68.99 .0004 75.49 .0001 87.56 .0004))
+
+ (p-c2 '(.98 .0629 1.99 .0232 2.98 .0217 4.00 .0396 4.98 .0171 5.97 .0098 6.99 .0167
+ 7.99 .0003 8.98 .0192 9.98 .0266 10.99 .0256 12.01 .0061 13.02 .0135 14.02 .0062 15.05 .0158
+ 16.06 .0018 17.08 .0101 18.09 .0053 19.11 .0074 20.13 .0020 21.17 .0052 22.22 .0077 23.24 .0035
+ 24.00 .0009 25.32 .0016 26.40 .0022 27.43 .0005 28.55 .0026 29.60 .0026 30.65 .0010 31.67 .0019
+ 32.77 .0008 33.81 .0003 34.91 .0003 36.01 .0005 37.11 .0010 38.20 .0014 39.29 .0039 40.43 .0012
+ 41.50 .0006 43.38 .0017 43.75 .0002 44.94 .0005 46.13 .0002 47.11 .0003 48.28 .0005 48.42 .0005
+ 49.44 .0003 50.76 .0004 51.93 .0002 54.15 .0003 55.31 .0005 55.50 .0003 56.98 .0003 57.90 .0004
+ 60.33 .0002 61.39 .0001 61.59 .0001 65.09 .0002 66.34 .0001 68.85 .0001 70.42 .0002 71.72 .0001
+ 73.05 .0003 79.65 .0001 85.28 .0002 93.52 .0001))
+
+ (p-cs2 '(1.02 .0185 1.99 .0525 2.98 .0613 3.99 .0415 4.98 .0109 5.97 .0248 6.99 .0102
+ 7.98 .0005 8.98 .0124 9.99 .0103 10.99 .0124 12.00 .0016 13.01 .0029 14.03 .0211 15.04 .0128
+ 16.07 .0021 17.09 .0009 18.09 .0043 19.14 .0022 20.13 .0016 21.20 .0045 22.21 .0088 23.26 .0046
+ 24.29 .0013 25.35 .0009 26.39 .0028 27.49 .0009 28.51 .0006 29.58 .0012 30.70 .0010 31.74 .0019
+ 32.75 .0002 33.85 .0001 34.95 .0005 36.02 .0003 37.16 .0009 38.25 .0018 39.35 .0008 40.54 .0004
+ 41.61 .0002 43.40 .0004 43.74 .0003 45.05 .0001 46.11 .0003 47.40 .0002 48.36 .0004 49.55 .0004
+ 50.72 .0002 52.00 .0001 55.58 .0002 57.02 .0001 57.98 .0002 59.13 .0003 61.56 .0001 66.56 .0001
+ 87.65 .0002))
+
+ (p-d2 '(1.00 .0473 1.99 .0506 2.99 .0982 3.99 .0654 5.00 .0196 5.99 .0094 6.99 .0118
+ 7.93 .0001 8.99 .0057 10.01 .0285 11.01 .0142 12.03 .0032 13.03 .0056 14.06 .0064 15.06 .0059
+ 16.11 .0005 17.09 .0033 18.14 .0027 19.15 .0014 20.17 .0010 21.21 .0059 22.26 .0043 23.31 .0031
+ 24.31 .0018 25.33 .0009 26.41 .0005 27.47 .0015 28.53 .0015 29.58 .0041 30.65 .0025 31.73 .0011
+ 32.83 .0010 34.98 .0003 36.07 .0009 37.23 .0001 38.26 .0020 39.41 .0014 40.53 .0005 41.40 .0003
+ 42.80 .0002 43.48 .0028 43.93 .0001 45.03 .0003 46.18 .0007 47.41 .0001 48.57 .0002 49.67 .0001
+ 50.83 .0002 54.39 .0001 55.58 .0002 57.97 .0005 58.11 .0002 59.21 .0001 60.42 .0002 61.66 .0001))
+
+ (p-ds2 '(1.00 .0503 2.00 .0963 2.99 .1304 3.99 .0218 4.98 .0041 5.98 .0292 6.98 .0482
+ 7.99 .0005 8.99 .0280 10.00 .0237 11.00 .0152 12.02 .0036 12.95 .0022 14.06 .0111 15.07 .0196
+ 16.08 .0016 17.11 .0044 18.13 .0073 19.17 .0055 20.19 .0028 21.20 .0012 22.27 .0068 23.30 .0036
+ 24.35 .0012 25.35 .0002 26.46 .0005 27.47 .0005 28.59 .0009 29.65 .0021 30.70 .0020 31.78 .0012
+ 32.89 .0010 35.06 .0005 36.16 .0008 37.27 .0010 38.36 .0010 39.47 .0014 40.58 .0004 41.43 .0007
+ 41.82 .0003 43.48 .0008 44.53 .0001 45.25 .0003 46.43 .0002 47.46 .0002 48.76 .0005 49.95 .0004
+ 50.96 .0002 51.12 .0002 52.33 .0001 54.75 .0001 55.75 .0002 56.90 .0002 58.17 .0002 59.40 .0004
+ 60.62 .0002 65.65 .0001 66.91 .0002 69.91 .0001 71.25 .0002))
+
+ (p-e2 '(1.00 .1243 1.98 .1611 3.00 .0698 3.98 .0390 5.00 .0138 5.99 .0154 7.01 .0287
+ 8.01 .0014 9.01 .0049 10.00 .0144 11.01 .0055 12.05 .0052 13.01 .0011 14.05 .0118 15.07 .0154
+ 16.12 .0028 17.14 .0061 18.25 .0007 19.22 .0020 20.24 .0011 21.27 .0029 22.30 .0046 23.34 .0049
+ 24.35 .0004 25.45 .0003 26.47 .0007 27.59 .0008 28.16 .0009 29.12 .0002 29.81 .0006 30.81 .0009
+ 31.95 .0004 33.00 .0011 34.12 .0005 35.18 .0003 36.30 .0008 37.38 .0003 38.55 .0003 39.64 .0006
+ 40.77 .0007 41.52 .0006 41.89 .0006 43.04 .0011 43.60 .0009 44.31 .0002 45.68 .0002 46.56 .0003
+ 47.60 .0001 48.83 .0006 50.01 .0003 51.27 .0003 56.04 .0005 57.21 .0003 58.56 .0004 59.83 .0003
+ 61.05 .0001 62.20 .0001 67.37 .0002 76.53 .0001))
+
+ (p-f2 '(.99 .0222 1.99 .0678 2.99 .0683 4.00 .0191 5.00 .0119 6.01 .0232 6.98 .0336
+ 7.99 .0082 9.01 .0201 10.01 .0189 11.01 .0041 12.01 .0053 13.05 .0154 14.04 .0159 15.06 .0092
+ 16.11 .0038 17.12 .0014 18.15 .0091 19.16 .0006 20.30 .0012 21.25 .0061 22.28 .0099 23.34 .0028
+ 24.38 .0012 25.43 .0016 26.49 .0048 27.55 .0025 28.62 .0015 29.71 .0032 30.78 .0077 31.88 .0011
+ 32.97 .0007 34.08 .0006 35.16 .0008 36.28 .0004 37.41 .0006 38.54 .0005 39.62 .0002 40.80 .0003
+ 41.93 .0001 43.06 .0002 44.21 .0003 45.38 .0002 46.54 .0007 47.78 .0003 48.95 .0004 50.10 .0003
+ 51.37 .0002 53.79 .0003 56.20 .0001 58.71 .0002 66.47 .0003))
+
+ (p-fs2 '(1.01 .0241 1.99 .1011 2.98 .0938 3.98 .0081 4.99 .0062 5.99 .0291 6.99 .0676
+ 7.59 .0004 8.98 .0127 9.99 .0112 10.99 .0142 12.00 .0029 13.02 .0071 14.02 .0184 15.03 .0064
+ 16.07 .0010 17.09 .0011 18.11 .0010 19.15 .0060 20.19 .0019 21.24 .0025 22.29 .0013 23.31 .0050
+ 25.41 .0030 26.50 .0018 27.53 .0006 28.63 .0012 29.66 .0013 30.77 .0020 31.84 .0006 34.04 .0001
+ 35.14 .0001 36.32 .0004 37.41 .0007 38.53 .0007 39.67 .0009 40.85 .0003 45.49 .0002 46.65 .0001
+ 47.81 .0004 49.01 .0002 53.91 .0002 55.14 .0002 57.69 .0002))
+
+ (p-g2 '(1.00 .0326 2.00 .1066 2.99 .1015 4.00 .0210 4.97 .0170 5.99 .0813 6.98 .0820
+ 7.96 .0011 8.99 .0248 10.03 .0107 11.01 .0126 12.01 .0027 13.01 .0233 14.04 .0151 15.05 .0071
+ 16.04 .0002 17.10 .0061 18.12 .0059 19.15 .0087 20.23 .0005 21.25 .0040 22.30 .0032 23.35 .0004
+ 24.40 .0001 25.45 .0030 26.54 .0022 27.60 .0003 28.70 .0009 29.80 .0029 30.85 .0006 31.97 .0006
+ 34.19 .0004 35.30 .0003 36.43 .0007 37.56 .0005 38.68 .0019 39.88 .0013 41.00 .0003 43.35 .0003
+ 44.51 .0002 45.68 .0006 46.93 .0010 48.11 .0006 49.29 .0003 55.58 .0002))
+
+ (p-gs2 '(.98 .0113 1.99 .0967 3.00 .0719 3.98 .0345 4.98 .0121 6.00 .0621 7.00 .0137
+ 7.98 .0006 9.01 .0314 10.01 .0171 11.02 .0060 12.03 .0024 13.05 .0077 14.07 .0040 15.12 .0032
+ 16.13 .0004 17.15 .0011 18.20 .0028 19.18 .0003 20.26 .0003 21.31 .0025 22.35 .0021 23.39 .0005
+ 25.55 .0002 26.62 .0014 27.70 .0003 28.78 .0005 29.90 .0030 31.01 .0011 32.12 .0005 34.31 .0001
+ 35.50 .0002 36.62 .0002 37.76 .0005 38.85 .0002 40.09 .0004 43.60 .0001 44.73 .0002 46.02 .0002
+ 47.25 .0004 48.44 .0004))
+
+ (p-a2 '(.99 .0156 1.98 .0846 2.98 .0178 3.98 .0367 4.98 .0448 5.98 .0113 6.99 .0189
+ 8.00 .0011 9.01 .0247 10.02 .0089 11.01 .0184 12.03 .0105 13.00 .0039 14.07 .0116 15.09 .0078
+ 16.13 .0008 17.14 .0064 18.19 .0029 19.22 .0028 20.25 .0017 21.32 .0043 22.37 .0055 23.42 .0034
+ 24.48 .0004 25.54 .0002 26.61 .0017 27.70 .0011 28.80 .0002 29.89 .0019 30.97 .0028 32.09 .0007
+ 34.30 .0002 35.44 .0003 36.55 .0001 37.69 .0004 38.93 .0002 40.05 .0005 41.20 .0005 42.37 .0002
+ 43.54 .0003 44.73 .0001 45.95 .0002 47.16 .0001 48.43 .0005 49.65 .0004 55.90 .0002 59.81 .0004))
+
+ (p-as2 '(1.01 .0280 2.00 .0708 2.99 .0182 3.99 .0248 4.98 .0245 5.98 .0279 6.98 .0437
+ 7.99 .0065 8.99 .0299 10.00 .0073 10.99 .0011 12.03 .0122 13.03 .0028 14.08 .0044 15.11 .0097
+ 16.15 .0010 17.17 .0025 18.19 .0017 19.24 .0008 20.28 .0040 21.32 .0024 22.38 .0008 23.46 .0032
+ 24.52 .0010 25.59 .0008 26.68 .0009 27.76 .0012 28.88 .0003 29.95 .0005 31.05 .0017 32.14 .0002
+ 33.29 .0003 37.88 .0002 39.03 .0002 40.19 .0004 41.37 .0003 43.74 .0002 46.20 .0001 48.68 .0001
+ 49.93 .0001 51.19 .0002))
+
+ (p-b2 '(1.00 .0225 1.99 .0921 2.98 .0933 3.99 .0365 4.99 .0100 5.98 .0213 6.98 .0049
+ 7.98 .0041 8.98 .0090 9.99 .0068 11.01 .0040 12.03 .0086 13.02 .0015 14.04 .0071 15.09 .0082
+ 16.14 .0011 17.15 .0014 18.18 .0010 19.26 .0013 20.26 .0005 21.33 .0006 22.36 .0011 23.46 .0016
+ 24.52 .0004 25.59 .0002 26.70 .0006 27.78 .0007 28.87 .0002 30.03 .0008 31.14 .0010 32.24 .0006
+ 33.37 .0002 35.67 .0003 37.99 .0004 39.17 .0004 40.35 .0005 41.53 .0001 46.42 .0001))
+
+ (p-c3 '(1.00 .0465 1.99 .0976 2.98 .0678 4.00 .0727 4.99 .0305 5.98 .0210 6.98 .0227
+ 8.00 .0085 9.01 .0183 10.02 .0258 11.05 .0003 12.06 .0061 13.05 .0021 14.10 .0089 15.12 .0077
+ 16.16 .0016 17.21 .0061 18.23 .0011 19.29 .0031 20.36 .0031 21.41 .0007 22.48 .0013 23.55 .0020
+ 24.64 .0004 25.74 .0005 26.81 .0006 27.95 .0006 29.03 .0001 30.22 .0010 31.30 .0004 32.48 .0001
+ 33.60 .0002 38.30 .0003))
+
+ (p-cs3 '(1.00 .0674 1.99 .0841 2.98 .0920 3.99 .0328 4.99 .0368 5.98 .0206 6.99 .0246
+ 8.01 .0048 9.01 .0218 10.03 .0155 11.05 .0048 12.06 .0077 13.00 .0020 14.10 .0083 15.15 .0084
+ 16.18 .0015 17.22 .0039 18.27 .0032 19.34 .0026 20.40 .0012 21.47 .0009 22.54 .0008 23.62 .0016
+ 24.71 .0005 25.82 .0004 26.91 .0002 28.03 .0008 29.17 .0002 30.32 .0028 31.45 .0004 32.61 .0005
+ 33.77 .0001 36.14 .0003 37.32 .0002 38.54 .0005 39.75 .0002 42.23 .0002 48.65 .0001))
+
+ (p-d3 '(1.01 .0423 1.99 .0240 2.98 .0517 4.00 .0493 5.00 .0324 6.00 .0094 6.99 .0449
+ 7.99 .0050 9.00 .0197 10.03 .0132 11.03 .0009 12.07 .0017 13.08 .0023 14.12 .0094 15.16 .0071
+ 16.21 .0020 17.25 .0005 18.30 .0027 19.04 .0004 20.43 .0022 21.51 .0002 22.59 .0006 23.72 .0018
+ 24.80 .0002 25.88 .0002 27.03 .0002 28.09 .0006 29.31 .0002 30.46 .0004 31.61 .0007 32.78 .0005
+ 33.95 .0001 36.34 .0002 37.56 .0001 38.80 .0001 40.02 .0001 44.14 .0001))
+
+ (p-ds3 '(1.00 .0669 1.99 .0909 2.99 .0410 3.98 .0292 4.98 .0259 5.98 .0148 6.98 .0319
+ 7.99 .0076 9.01 .0056 10.02 .0206 11.04 .0032 12.05 .0085 13.08 .0040 14.12 .0037 15.16 .0030
+ 16.20 .0013 17.24 .0021 18.30 .0010 19.36 .0015 20.44 .0013 21.50 .0009 22.60 .0015 23.69 .0014
+ 24.80 .0006 25.87 .0002 27.02 .0006 28.12 .0002 29.28 .0003 30.43 .0002 31.59 .0007 32.79 .0001
+ 35.14 .0001 37.57 .0001 40.03 .0002 41.28 .0004 44.10 .0001))
+
+ (p-e3 '(.99 .0421 1.99 .1541 2.98 .0596 3.98 .0309 4.98 .0301 5.99 .0103 7.00 .0240
+ 8.01 .0073 9.01 .0222 10.04 .0140 11.05 .0033 12.08 .0045 13.13 .0009 14.13 .0015 15.21 .0026
+ 16.24 .0003 17.30 .0004 18.35 .0010 19.39 .0003 20.50 .0015 21.57 .0003 22.68 .0011 23.80 .0005
+ 24.90 .0008 26.02 .0002 27.16 .0001 28.30 .0006 29.48 .0002 31.81 .0005 33.00 .0003 34.21 .0001
+ 37.89 .0001))
+
+ (p-f3 '(.99 .0389 2.00 .2095 3.00 .0835 3.99 .0289 5.00 .0578 5.99 .0363 7.01 .0387
+ 8.01 .0056 9.04 .0173 10.05 .0175 11.08 .0053 12.10 .0056 13.15 .0064 14.19 .0036 15.22 .0019
+ 16.29 .0010 17.36 .0017 18.43 .0018 19.51 .0004 20.60 .0011 21.70 .0003 22.82 .0003 23.95 .0001
+ 25.05 .0004 26.17 .0001 28.50 .0003 29.68 .0001 32.07 .0003 33.28 .0004 34.52 .0001))
+
+ (p-fs3 '(1.00 .1238 1.99 .2270 3.00 .0102 3.99 .0181 4.98 .0415 6.00 .0165 7.01 .0314
+ 8.02 .0148 9.04 .0203 10.05 .0088 11.07 .0062 12.11 .0070 13.14 .0054 14.19 .0028 15.24 .0044
+ 16.30 .0029 17.38 .0009 18.45 .0026 19.56 .0003 20.65 .0025 21.74 .0014 22.87 .0013 23.99 .0007
+ 25.15 .0002 27.46 .0004 28.39 .0006 28.65 .0004 29.85 .0001 31.05 .0002 32.27 .0003 33.52 .0002
+ 34.76 .0003))
+
+ (p-g3 '(1.00 .1054 2.00 .2598 2.99 .0369 3.98 .0523 4.99 .0020 5.99 .0051 7.00 .0268
+ 8.01 .0027 9.04 .0029 10.05 .0081 11.08 .0047 12.12 .0051 13.16 .0091 14.19 .0015 15.27 .0030
+ 16.34 .0017 17.42 .0006 18.51 .0003 19.61 .0007 20.72 .0003 21.84 .0001 22.99 .0010 24.13 .0001
+ 28.44 .0001 30.09 .0001))
+
+ (p-gs3 '(.99 .0919 2.00 .0418 2.99 .0498 3.99 .0135 4.99 .0026 6.00 .0155 7.01 .0340
+ 8.02 .0033 9.04 .0218 10.08 .0084 11.11 .0057 12.15 .0051 13.21 .0043 14.25 .0015 15.31 .0023
+ 16.40 .0008 17.48 .0004 18.59 .0016 19.71 .0010 20.84 .0018 21.98 .0002 23.11 .0013 24.26 .0003
+ 26.67 .0002 29.12 .0002 30.37 .0002 31.62 .0003 32.92 .0001))
+
+ (p-a3 '(.99 .1174 1.99 .1126 2.99 .0370 3.99 .0159 5.01 .0472 6.01 .0091 7.03 .0211
+ 8.05 .0015 9.07 .0098 10.11 .0038 11.15 .0042 12.20 .0018 13.24 .0041 14.32 .0033 15.41 .0052
+ 16.49 .0001 17.61 .0004 18.71 .0004 19.84 .0004 20.99 .0002 22.14 .0006 23.31 .0006 24.50 .0004
+ 25.70 .0002 28.09 .0002 28.66 .0002 32.00 .0001))
+
+ (p-as3 '(1.00 .1085 2.00 .1400 2.99 .0173 3.99 .0229 5.00 .0272 6.02 .0077 7.03 .0069
+ 8.04 .0017 9.08 .0045 10.10 .0030 11.15 .0040 12.20 .0007 13.25 .0019 14.32 .0008 15.42 .0024
+ 16.50 .0002 17.59 .0005 18.71 .0003 19.83 .0002 20.98 .0005 23.29 .0008))
+
+ (p-b3 '(1.00 .0985 2.00 .1440 2.99 .0364 3.99 .0425 5.00 .0190 6.01 .0089 7.03 .0278
+ 8.04 .0006 9.07 .0083 10.10 .0021 11.14 .0050 12.18 .0005 13.26 .0036 14.33 .0005 15.41 .0026
+ 17.62 .0004 18.75 .0004 19.89 .0003 21.04 .0012 22.21 .0002 23.38 .0004 27.04 .0001))
+
+ (p-c4 '(.99 .1273 2.00 .1311 2.99 .0120 4.00 .0099 5.00 .0235 6.02 .0068 7.03 .0162
+ 8.06 .0009 9.08 .0083 10.12 .0014 11.17 .0050 12.24 .0010 13.29 .0013 14.39 .0022 15.48 .0011
+ 16.59 .0002 17.70 .0003 18.84 .0010 20.00 .0003 21.17 .0003 23.56 .0004 28.79 .0003))
+
+ (p-cs4 '(1.00 .1018 2.00 .1486 3.00 .0165 4.00 .0186 5.01 .0194 6.02 .0045 7.04 .0083
+ 8.06 .0012 9.10 .0066 10.15 .0009 11.19 .0008 12.26 .0011 13.34 .0028 14.45 .0006 15.53 .0009
+ 16.66 .0002 17.79 .0006 18.94 .0005 20.11 .0003 21.29 .0005 22.49 .0003 23.73 .0005 26.22 .0001
+ 27.52 .0001 28.88 .0002))
+
+ (p-d4 '(1.00 .1889 1.99 .1822 3.00 .0363 4.00 .0047 5.01 .0202 6.03 .0053 7.05 .0114
+ 8.01 .0002 9.13 .0048 10.17 .0010 11.23 .0033 12.30 .0010 13.38 .0006 14.50 .0002 15.62 .0010
+ 20.27 .0001 21.47 .0001))
+
+ (p-ds4 '(1.00 .0522 1.99 .0763 2.99 .0404 4.00 .0139 5.01 .0185 6.01 .0021 7.06 .0045
+ 8.09 .0002 9.11 .0003 10.17 .0006 11.25 .0004 12.32 .0005 13.40 .0003 14.53 .0003 15.65 .0007
+ 16.80 .0001 17.95 .0002 19.14 .0006 20.34 .0002 21.56 .0003))
+
+ (p-e4 '(.99 .1821 1.99 .0773 3.00 .0125 4.01 .0065 5.01 .0202 6.03 .0071 7.05 .0090
+ 8.08 .0006 9.13 .0008 10.18 .0013 11.25 .0010 12.33 .0012 13.42 .0006 14.54 .0005 15.65 .0004
+ 17.97 .0002 19.15 .0001))
+
+ (p-f4 '(1.00 .1868 2.00 .0951 3.00 .0147 4.01 .0134 5.02 .0184 6.04 .0132 7.06 .0011
+ 8.11 .0008 9.15 .0010 10.22 .0012 11.30 .0011 12.40 .0003 13.11 .0004 13.49 .0002 14.62 .0003
+ 15.77 .0001))
+
+ (p-fs4 '(1.00 .1933 2.00 .0714 3.00 .0373 4.00 .0108 5.02 .0094 6.02 .0010 7.07 .0022
+ 8.11 .0002 9.16 .0065 10.23 .0015 11.31 .0023 12.40 .0003 13.53 .0014 14.66 .0002 15.81 .0011
+ 18.20 .0002 19.41 .0001))
+
+ (p-g4 '(.99 .2113 1.99 .0877 3.00 .0492 4.01 .0094 5.02 .0144 6.04 .0103 7.07 .0117
+ 8.12 .0006 9.19 .0019 10.25 .0007 11.35 .0017 12.45 .0010 13.58 .0003 14.74 .0003 15.91 .0003
+ 19.57 .0002))
+
+ (p-gs4 '(.99 .2455 1.99 .0161 3.00 .0215 4.01 .0036 5.03 .0049 6.04 .0012 7.09 .0036
+ 8.14 .0011 9.21 .0009 10.30 .0001 11.40 .0012 12.50 .0001 13.66 .0005 14.84 .0001))
+
+ (p-a4 '(1.00 .1132 2.00 .0252 3.00 .0292 4.01 .0136 5.03 .0045 6.06 .0022 7.11 .0101
+ 8.17 .0004 9.23 .0010 10.33 .0012 11.44 .0013 12.58 .0011 13.75 .0002 14.93 .0005 16.14 .0002))
+
+ (p-as4 '(1.00 .1655 2.00 .0445 3.00 .0120 4.00 .0038 5.02 .0015 6.07 .0038 7.11 .0003
+ 8.19 .0002 9.25 .0010 10.36 .0011 11.48 .0005 12.63 .0002 13.79 .0003 16.24 .0002))
+
+ (p-b4 '(.99 .3637 1.99 .0259 3.01 .0038 4.01 .0057 5.03 .0040 6.07 .0067 7.12 .0014
+ 8.19 .0004 9.27 .0003 10.38 .0002 12.67 .0001))
+
+ (p-c5 '(1.00 .1193 2.00 .0230 3.00 .0104 4.01 .0084 5.04 .0047 6.08 .0035 7.13 .0041
+ 8.20 .0002 9.29 .0005 10.40 .0005 11.53 .0003 12.70 .0002 13.91 .0002))
+
+ (p-cs5 '(1.00 .0752 2.00 .0497 3.00 .0074 4.02 .0076 5.05 .0053 6.09 .0043 7.15 .0024
+ 8.22 .0001 9.32 .0006 10.45 .0002 11.58 .0001 12.78 .0001 15.22 .0001))
+
+ (p-d5 '(1.00 .2388 2.00 .0629 3.01 .0159 4.04 .0063 5.07 .0051 6.12 .0045 7.19 .0026
+ 8.29 .0015 9.43 .0001 11.75 .0002))
+
+ (p-ds5 '(1.00 .1919 2.01 .0116 3.01 .0031 4.03 .0090 5.07 .0061 6.13 .0036 7.19 .0013
+ 8.30 .0016 9.13 .0001 10.59 .0002 11.78 .0002))
+
+ (p-e5 '(1.00 .1296 2.00 .0135 3.01 .0041 4.04 .0045 5.09 .0028 6.14 .0046 7.23 .0007
+ 8.32 .0007 9.50 .0001))
+
+ (p-f5 '(1.00 .0692 2.00 .0209 3.02 .0025 4.05 .0030 5.09 .0047 6.17 .0022 7.25 .0015
+ 8.36 .0015 9.53 .0010 10.69 .0001 13.40 .0001))
+
+ (p-fs5 '(1.00 .1715 2.00 .0142 3.01 .0024 4.03 .0015 5.07 .0017 6.13 .0018 7.22 .0009
+ 8.33 .0014 9.51 .0007 10.69 .0002))
+
+ (p-g5 '(1.00 .1555 2.01 .0148 3.02 .0007 4.06 .0006 5.10 .0005 6.16 .0008 7.26 .0009
+ 8.39 .0008 9.58 .0002))
+
+ (p-gs5 '(1.00 .1357 2.00 .0116 3.02 .0026 4.04 .0009 5.09 .0004 6.17 .0005 7.27 .0002
+ 8.40 .0001))
+
+ (p-a5 '(1.00 .2185 2.01 .0087 3.03 .0018 4.06 .0025 5.11 .0020 6.20 .0012 7.32 .0005
+ 8.46 .0001 9.66 .0003))
+
+ (p-as5 '(1.00 .2735 2.00 .0038 3.02 .0008 4.06 .0012 5.12 .0008 6.22 .0011 7.35 .0003
+ 8.50 .0002))
+
+ (p-b5 '(1.00 .1441 1.99 .0062 3.01 .0023 4.05 .0011 5.11 .0012 6.20 .0003 7.33 .0004
+ 8.50 .0001))
+
+ (p-c6 '(1.00 .0726 2.01 .0293 3.03 .0022 5.14 .0005 6.26 .0011 7.41 .0002 8.63 .0002))
+
+ (p-cs6 '(1.00 .0516 2.00 .0104 3.02 .0029 5.15 .0002 6.27 .0001))
+
+ (p-d6 '(1.00 .0329 2.00 .0033 3.03 .0013 4.10 .0005 5.19 .0004 6.32 .0002))
+
+ (p-ds6 '(1.00 .0179 1.99 .0012 3.04 .0005 4.10 .0017 5.20 .0005 6.35 .0001))
+
+ (p-e6 '(1.00 .0334 2.01 .0033 3.04 .0011 4.13 .0003 5.22 .0003))
+
+ (p-f6 '(.99 .0161 2.01 .0100 3.04 .0020 4.13 .0003))
+
+ (p-fs6 '(1.00 .0475 1.99 .0045 3.03 .0035 4.12 .0011))
+
+ (p-g6 '(1.00 .0593 2.00 .0014 4.17 .0002))
+
+ (p-gs6 '(1.00 .0249 2.01 .0016))
+
+ (p-a6 '(1.00 .0242 2.00 .0038 4.19 .0002))
+
+ (p-as6 '(1.00 .0170 2.02 .0030))
+
+ (p-b6 '(1.00 .0381 2.00 .0017 3.09 .0002))
+
+ (p-c7 '(1.00 .0141 2.03 .0005 3.11 .0003 4.26 .0001))
+
+ (p-cs7 '(1.00 .0122 2.03 .0024))
+
+ (p-d7 '(1.00 .0107 2.07 .0007 3.12 .0004))
+
+ (p-ds7 '(1.00 .0250 2.02 .0026 3.15 .0002))
+
+ (p-e7 '(1.01 .0092))
+
+ (p-f7 '(1.01 .0102 2.09 .0005))
+
+ (p-fs7 '(1.00 .0080 2.00 .0005 3.19 .0001))
+
+ (p-g7 '(1.01 .0298 2.01 .0005))
+
+ ;; sax
+ (sax-cs3 '(1.01 .0565 2.01 .0374 3.00 .0377 4.00 .0498 5.02 .0907 6.02 .0361 7.02 .0250
+ 8.01 .0036 9.02 .0181 10.03 .0319 11.03 .0075 12.03 .0068 13.03 .0037 14.03 .0015 15.05 .0021
+ 16.04 .0034 17.04 .0076 18.04 .0101 19.06 .0056 20.06 .0051 21.05 .0046 22.05 .0029 23.05 .0015
+ 24.07 .0026 25.07 .0023 26.06 .0025 27.06 .0010 28.08 .0011 29.08 .0005 30.07 .0017 31.07 .0025
+ 32.07 .0032 33.09 .0026 34.09 .0023 35.09 .0038 36.09 .0023 37.09 .0018 38.11 .0023 39.11 .0017
+ 40.10 .0015 41.10 .0010 42.10 .0008 43.13 .0004 45.13 .0001 46.11 .0005 47.12 .0004 48.12 .0006
+ 49.11 .0004 50.12 .0008 51.13 .0006 52.14 .0009 53.13 .0006 54.13 .0008 55.13 .0007 56.15 .0005
+ 57.16 .0002 58.13 .0001 59.17 .0001 61.15 .0001 62.15 .0002 63.16 .0002 65.17 .0004 66.18 .0005
+ 67.18 .0003 68.17 .0002 69.17 .0005 70.18 .0003 71.18 .0002 72.18 .0005 73.18 .0003 74.18 .0003
+ 75.20 .0003 76.19 .0003 77.19 .0002 78.19 .0004 80.20 .0002 81.19 .0001 82.21 .0001 89.23 .0002
+ 90.23 .0002 91.23 .0003 92.22 .0001))
+
+ (sax-d3 '(1.00 .0423 1.99 .0487 2.98 .0259 3.99 .0630 4.99 .1026 5.97 .0532 6.97 .0259
+ 7.98 .0110 8.97 .0076 9.96 .0123 10.97 .0162 11.96 .0128 12.95 .0178 13.94 .0114 14.96 .0134
+ 15.95 .0186 16.94 .0180 17.93 .0087 18.94 .0084 19.93 .0064 20.92 .0033 21.93 .0025 22.93 .0041
+ 23.91 .0041 24.90 .0034 25.91 .0012 26.90 .0013 27.90 .0020 28.89 .0036 29.90 .0054 30.89 .0054
+ 31.88 .0038 32.89 .0059 33.89 .0037 34.88 .0024 35.86 .0024 36.87 .0023 37.87 .0017 38.86 .0020
+ 39.85 .0019 40.86 .0021 41.86 .0007 42.84 .0012 43.84 .0007 44.84 .0010 45.85 .0005 46.82 .0006
+ 47.84 .0009 48.82 .0009 49.82 .0006 50.81 .0008 51.82 .0012 52.80 .0012 54.81 .0005 55.78 .0003
+ 56.79 .0003 57.78 .0003 58.79 .0003 59.80 .0004 60.77 .0003 61.78 .0004 62.77 .0005 63.77 .0001
+ 64.75 .0004 65.76 .0003 66.77 .0003 67.76 .0006 68.75 .0006 69.75 .0007 70.74 .0004 71.74 .0010
+ 72.73 .0008 73.74 .0007 75.74 .0002 76.72 .0004 77.72 .0002 78.71 .0004 79.70 .0001 80.71 .0001
+ 81.70 .0002 82.70 .0001 83.70 .0004 84.69 .0003 85.68 .0008 86.68 .0003 87.69 .0001 88.69 .0002
+ 90.66 .0001))
+
+ (sax-ds3 '(1.00 .0338 1.99 .0765 2.97 .0602 3.96 .0870 4.97 .1666 5.96 .0394 6.95 .0067
+ 7.94 .0199 8.94 .0418 9.93 .0110 10.92 .0101 11.91 .0077 12.90 .0052 13.91 .0148 14.90 .0172
+ 15.88 .0218 16.87 .0110 17.88 .0086 18.87 .0045 19.86 .0009 20.85 .0014 21.85 .0045 22.84 .0037
+ 23.83 .0010 24.82 .0028 25.81 .0013 26.82 .0032 27.81 .0040 28.79 .0067 29.78 .0035 30.79 .0041
+ 31.78 .0028 32.76 .0017 33.75 .0011 34.76 .0015 35.75 .0018 36.73 .0021 37.72 .0017 38.71 .0019
+ 39.72 .0014 40.71 .0015 41.70 .0016 42.69 .0006 43.69 .0021 44.69 .0024 45.67 .0003 46.66 .0014
+ 47.66 .0002 48.66 .0011 49.65 .0010 50.63 .0002 51.62 .0008 52.63 .0007 53.62 .0008 54.60 .0004
+ 56.59 .0005 57.59 .0003 58.58 .0007 60.56 .0004 61.56 .0002 62.55 .0004 63.54 .0004 64.53 .0008
+ 65.54 .0011 66.53 .0003 67.52 .0009 68.51 .0008 69.51 .0013 70.50 .0002 71.49 .0004 72.47 .0004
+ 73.47 .0002 74.48 .0002 75.46 .0002 76.45 .0005 77.45 .0003 78.45 .0008 79.44 .0003 80.42 .0008
+ 81.41 .0005 82.41 .0001 83.42 .0001))
+
+ (sax-e3 '(1.00 .0225 1.99 .0627 2.99 .0834 3.98 .0804 4.98 .0984 5.97 .0393 6.96 .0345
+ 7.96 .0102 8.95 .0084 9.94 .0129 10.93 .0214 11.93 .0154 12.92 .0184 13.91 .0167 14.91 .0213
+ 15.90 .0116 16.89 .0090 17.88 .0045 18.88 .0008 19.87 .0024 20.86 .0045 21.86 .0058 22.85 .0012
+ 23.84 .0012 24.84 .0030 25.83 .0035 26.82 .0067 27.83 .0048 28.82 .0016 29.82 .0012 30.81 .0015
+ 31.81 .0032 32.80 .0033 33.80 .0038 34.79 .0032 35.78 .0025 36.78 .0008 37.77 .0007 38.76 .0020
+ 39.75 .0009 40.75 .0007 41.74 .0018 42.73 .0024 43.72 .0012 44.72 .0016 45.71 .0015 46.70 .0019
+ 47.69 .0005 48.69 .0007 49.68 .0006 50.67 .0003 51.68 .0006 52.67 .0002 53.66 .0004 54.65 .0004
+ 55.65 .0005 56.64 .0004 57.64 .0006 58.64 .0004 59.64 .0004 60.63 .0011 61.62 .0004 62.62 .0003
+ 63.61 .0005 64.60 .0011 65.60 .0010 65.74 .0001 66.59 .0001 67.58 .0006 68.57 .0007 69.56 .0003
+ 70.56 .0002 71.56 .0002 72.55 .0007 73.54 .0009 74.53 .0008 75.52 .0007 76.52 .0006 77.51 .0002
+ 79.50 .0002))
+
+ (sax-f3 '(.98 .0394 1.98 .0562 2.97 .0897 3.96 .0683 4.96 .0231 5.95 .0309 6.94 .0308
+ 7.91 .0176 8.91 .0089 9.90 .0084 10.89 .0141 11.89 .0045 12.88 .0070 13.87 .0083 14.85 .0142
+ 15.84 .0089 16.83 .0048 17.82 .0015 18.82 .0028 19.82 .0027 20.81 .0015 21.79 .0012 22.77 .0015
+ 23.76 .0050 24.76 .0041 25.75 .0048 26.75 .0015 27.74 .0007 28.73 .0011 29.71 .0016 30.70 .0020
+ 31.69 .0019 32.68 .0032 33.68 .0026 34.67 .0014 35.66 .0013 36.64 .0009 37.63 .0014 38.62 .0009
+ 39.61 .0018 40.61 .0008 41.60 .0013 42.59 .0007 43.57 .0010 44.56 .0006 45.57 .0002 46.54 .0009
+ 47.53 .0005 48.51 .0002 49.53 .0001 50.52 .0005 51.49 .0002 52.49 .0006 53.47 .0001 54.48 .0002
+ 55.46 .0003 56.47 .0002 57.45 .0006 58.43 .0004 59.42 .0003 60.41 .0006 61.41 .0005 62.40 .0005
+ 63.40 .0002 64.38 .0003 65.37 .0001 66.35 .0002 68.34 .0005 69.33 .0003 70.33 .0005 71.32 .0001
+ 72.30 .0002 75.27 .0001))
+
+ (sax-fs3 '(.99 .0784 1.99 .0550 2.97 .0439 3.97 .0998 4.95 .0679 5.95 .0244 6.93 .0178
+ 7.94 .0130 8.92 .0186 9.92 .0204 10.90 .0091 11.90 .0102 12.88 .0166 13.88 .0130 14.86 .0079
+ 15.86 .0039 16.86 .0023 17.84 .0052 18.84 .0049 19.82 .0042 20.82 .0027 21.81 .0027 22.80 .0057
+ 23.78 .0042 24.79 .0042 25.77 .0015 26.77 .0008 27.75 .0020 28.75 .0021 29.73 .0032 30.73 .0036
+ 31.71 .0022 32.71 .0011 33.71 .0015 34.69 .0011 35.69 .0012 36.67 .0013 37.67 .0014 38.65 .0006
+ 39.65 .0013 40.64 .0004 41.63 .0010 42.62 .0002 43.62 .0010 44.60 .0003 45.59 .0003 46.58 .0004
+ 47.59 .0005 48.57 .0002 49.55 .0005 50.55 .0002 51.54 .0002 52.53 .0005 53.53 .0006 54.52 .0006
+ 55.51 .0002 56.50 .0008 57.47 .0003 58.48 .0007 59.47 .0003 60.46 .0002 61.44 .0002 62.45 .0002
+ 63.43 .0001 64.43 .0004 65.42 .0005 66.41 .0007 67.40 .0002 68.39 .0002 69.39 .0002 70.37 .0001))
+
+ (sax-g3 '(1.00 .1076 1.99 .0463 2.98 .1092 3.97 .0816 4.95 .0831 5.94 .0118 6.93 .0095
+ 7.94 .0104 8.93 .0148 9.92 .0144 10.91 .0117 11.90 .0196 12.89 .0153 13.88 .0107 14.87 .0052
+ 15.86 .0033 16.86 .0058 17.85 .0042 18.83 .0013 19.83 .0029 20.82 .0067 21.81 .0040 22.80 .0057
+ 23.79 .0022 24.79 .0019 25.78 .0009 26.78 .0017 27.76 .0025 28.76 .0024 29.74 .0020 30.73 .0011
+ 31.72 .0010 32.73 .0007 33.72 .0013 34.70 .0019 35.69 .0017 36.69 .0011 37.67 .0006 38.67 .0008
+ 39.67 .0005 40.66 .0005 41.65 .0011 42.64 .0003 43.63 .0004 44.62 .0007 45.60 .0007 46.60 .0006
+ 47.59 .0006 48.59 .0003 49.59 .0007 50.57 .0006 51.57 .0007 52.55 .0003 53.54 .0008 54.53 .0005
+ 55.53 .0005 56.51 .0003 57.52 .0005 59.50 .0001 60.48 .0002 61.47 .0006 62.46 .0005 63.46 .0003
+ 64.46 .0002 65.45 .0002))
+
+ (sax-gs3 '(.98 .0781 1.97 .0393 2.96 .0842 3.94 .0434 4.93 .0378 5.91 .0141 6.89 .0201
+ 7.87 .0294 8.86 .0169 9.85 .0124 10.84 .0137 11.81 .0238 12.80 .0172 13.78 .0094 14.77 .0040
+ 15.76 .0036 16.74 .0061 17.72 .0032 18.70 .0035 19.69 .0086 20.68 .0065 21.66 .0097 22.65 .0036
+ 23.63 .0010 24.62 .0006 25.61 .0018 26.59 .0026 27.58 .0023 28.56 .0017 29.54 .0010 30.52 .0012
+ 31.50 .0018 32.50 .0021 33.48 .0025 34.46 .0010 35.45 .0028 36.42 .0018 37.41 .0009 38.41 .0007
+ 39.38 .0006 40.37 .0004 41.36 .0005 42.34 .0007 43.31 .0001 44.29 .0002 45.29 .0006 46.28 .0005
+ 47.26 .0005 48.25 .0006 49.22 .0006 50.21 .0003 51.20 .0007 52.18 .0004 53.16 .0003 54.15 .0004
+ 55.14 .0001 56.10 .0001 57.11 .0005 58.09 .0007 59.07 .0005 59.22 .0001 61.04 .0004 63.02 .0002))
+
+ (sax-a3 '(.99 .0950 1.97 .0374 2.95 .0738 3.94 .0772 4.93 .0103 5.92 .0135 6.90 .0099
+ 7.88 .0088 8.88 .0151 9.86 .0150 10.84 .0177 11.83 .0121 12.82 .0071 13.81 .0049 14.79 .0025
+ 15.77 .0046 16.77 .0023 17.75 .0020 18.73 .0079 19.71 .0057 20.70 .0068 21.69 .0036 22.67 .0007
+ 23.65 .0003 24.65 .0006 25.64 .0016 26.62 .0013 27.60 .0006 28.59 .0005 29.59 .0005 30.56 .0013
+ 31.55 .0015 32.53 .0013 33.52 .0009 34.51 .0016 35.48 .0002 36.47 .0007 37.46 .0002 38.46 .0003
+ 39.43 .0002 40.42 .0003 41.40 .0006 42.40 .0006 43.39 .0002 44.36 .0009 45.35 .0008 46.34 .0010
+ 47.32 .0003 48.30 .0009 49.29 .0006 50.28 .0002 51.27 .0004 52.25 .0002 54.23 .0003 55.21 .0001
+ 56.19 .0002 58.17 .0002))
+
+ (sax-as3 '(.99 .0856 1.98 .0365 2.97 .0409 3.96 .0666 4.94 .0192 5.94 .0263 6.92 .0311
+ 7.91 .0175 8.90 .0203 9.89 .0358 10.87 .0214 11.87 .0177 12.85 .0068 13.84 .0071 14.83 .0068
+ 15.82 .0040 16.80 .0040 17.80 .0126 18.78 .0101 19.77 .0086 20.75 .0053 21.75 .0012 22.73 .0026
+ 23.73 .0019 24.71 .0018 25.71 .0026 26.68 .0023 27.68 .0022 28.66 .0015 29.66 .0031 30.64 .0008
+ 31.63 .0023 32.61 .0029 33.61 .0007 34.59 .0016 35.59 .0009 36.57 .0006 37.56 .0012 38.54 .0004
+ 39.53 .0005 40.52 .0007 41.52 .0006 42.50 .0009 43.50 .0015 44.48 .0005 45.47 .0012 46.46 .0007
+ 47.45 .0003 48.44 .0007 49.41 .0003 50.41 .0003 51.40 .0011 52.39 .0007 53.37 .0005 54.36 .0005
+ 55.34 .0002 56.34 .0002))
+
+ (sax-b3 '(.99 .1015 1.99 .0817 2.98 .0315 3.98 .0386 4.97 .0424 5.96 .0104 6.96 .0144
+ 7.94 .0361 8.94 .0182 9.93 .0238 10.93 .0139 11.93 .0063 12.91 .0058 13.91 .0071 14.91 .0051
+ 15.89 .0035 16.90 .0114 17.88 .0097 18.88 .0081 19.87 .0043 20.86 .0014 21.86 .0009 22.85 .0012
+ 23.86 .0006 24.84 .0013 25.83 .0006 26.83 .0010 27.82 .0015 28.80 .0008 29.80 .0012 30.80 .0017
+ 31.77 .0002 32.78 .0016 33.78 .0006 34.77 .0003 35.77 .0009 36.76 .0006 37.75 .0011 38.75 .0006
+ 39.74 .0011 40.74 .0011 41.73 .0006 42.72 .0015 43.72 .0008 44.70 .0002 45.71 .0005 46.70 .0004
+ 47.69 .0003 48.69 .0005 49.67 .0005 50.64 .0001 51.66 .0003))
+
+ (sax-c4 '(.99 .1462 1.98 .0760 2.98 .0464 3.97 .0292 4.95 .0393 5.95 .0117 6.94 .0150
+ 7.93 .0251 8.93 .0238 9.92 .0182 10.90 .0142 11.89 .0100 12.89 .0108 13.88 .0029 14.87 .0060
+ 15.86 .0116 16.85 .0066 17.84 .0072 18.84 .0034 19.83 .0010 20.82 .0013 21.81 .0015 22.80 .0012
+ 23.80 .0011 24.79 .0004 25.77 .0027 26.76 .0021 27.75 .0018 28.75 .0013 29.74 .0015 30.73 .0008
+ 31.72 .0004 32.71 .0007 33.71 .0011 34.70 .0002 35.68 .0010 36.67 .0002 37.66 .0003 38.67 .0010
+ 39.66 .0008 40.64 .0019 41.64 .0005 42.62 .0010 43.62 .0003 45.60 .0005 46.59 .0002 47.59 .0002
+ 48.58 .0002 49.57 .0002 50.55 .0001))
+
+ (sax-cs4 '(.99 .0832 1.97 .0162 2.96 .0337 3.95 .0272 4.94 .0264 5.93 .0256 6.93 .0180
+ 7.92 .0206 8.90 .0167 9.89 .0172 10.88 .0075 11.86 .0087 12.85 .0048 13.85 .0051 14.83 .0134
+ 15.83 .0091 16.82 .0065 17.80 .0008 18.80 .0018 19.78 .0023 20.77 .0025 21.76 .0021 22.74 .0013
+ 23.74 .0011 24.72 .0032 25.72 .0006 26.72 .0005 27.69 .0026 28.69 .0009 29.68 .0006 30.66 .0003
+ 31.65 .0007 32.64 .0003 33.62 .0014 34.61 .0007 35.60 .0007 36.59 .0005 37.60 .0004 38.56 .0006
+ 39.54 .0004 40.55 .0004 41.55 .0003 42.50 .0002 43.51 .0005 44.50 .0003 45.50 .0002 46.48 .0002
+ 47.48 .0002))
+
+ (sax-d4 '(.98 .0860 1.97 .0143 2.95 .0061 3.94 .0407 4.93 .0204 5.91 .0066 6.90 .0372
+ 7.89 .0217 8.87 .0220 9.86 .0147 10.85 .0042 11.83 .0072 12.82 .0023 13.81 .0074 14.79 .0104
+ 15.78 .0050 16.76 .0005 17.74 .0036 18.73 .0056 19.71 .0022 20.70 .0040 21.69 .0021 22.68 .0018
+ 23.66 .0026 24.65 .0035 25.64 .0021 26.62 .0011 27.61 .0013 28.59 .0006 29.58 .0002 30.57 .0010
+ 31.69 .0001 32.54 .0004 33.52 .0009 34.50 .0005 35.49 .0004 36.47 .0013 37.46 .0015 38.45 .0009
+ 39.43 .0003 40.42 .0004 41.41 .0008 42.40 .0005 43.38 .0004 44.37 .0006))
+
+ (sax-ds4 '(.98 .0870 1.97 .0204 2.96 .0184 3.94 .0494 4.92 .0500 5.91 .0163 6.90 .0267
+ 7.88 .0158 8.86 .0159 9.85 .0095 10.84 .0095 11.82 .0039 12.81 .0053 13.79 .0074 14.78 .0054
+ 15.77 .0004 16.75 .0027 17.73 .0034 18.71 .0035 19.70 .0019 20.69 .0028 21.67 .0032 22.65 .0016
+ 23.64 .0018 24.63 .0033 25.61 .0006 26.59 .0015 27.58 .0005 28.57 .0010 29.56 .0006 30.54 .0010
+ 31.52 .0009 32.51 .0004 33.50 .0012 34.47 .0006 35.46 .0009 36.45 .0007 37.44 .0002 38.42 .0006
+ 39.41 .0003 40.38 .0003 41.38 .0005 42.36 .0003))
+
+ (sax-e4 '(.99 .0111 1.97 .0520 2.96 .0287 3.94 .0704 4.93 .0240 5.91 .0286 6.89 .0516
+ 7.89 .0184 8.87 .0076 9.86 .0113 10.84 .0049 11.83 .0044 12.81 .0111 13.79 .0080 14.78 .0008
+ 15.76 .0031 16.76 .0042 17.74 .0016 18.73 .0021 19.71 .0010 20.69 .0048 21.68 .0014 22.66 .0020
+ 23.66 .0016 24.64 .0011 25.62 .0011 26.61 .0001 27.59 .0011 28.58 .0013 29.56 .0011 30.55 .0004
+ 31.54 .0015 32.52 .0023 33.51 .0015 34.49 .0004 35.48 .0003 36.46 .0007 37.45 .0003 38.43 .0003
+ 39.42 .0009))
+
+ (sax-f4 '(1.00 .0896 2.00 .1802 3.00 .0636 4.00 .0344 5.01 .0214 6.01 .0196 7.01 .0241
+ 8.01 .0118 9.01 .0057 10.01 .0060 11.01 .0059 12.01 .0032 13.02 .0055 14.02 .0023 15.01 .0020
+ 16.02 .0027 17.02 .0022 18.02 .0017 19.02 .0015 20.02 .0020 21.03 .0014 22.03 .0010 23.02 .0006
+ 24.03 .0007 25.03 .0005 27.03 .0006 28.03 .0005 29.04 .0003 30.04 .0009 31.03 .0006 32.04 .0003
+ 33.04 .0002 34.04 .0003 35.04 .0001 36.04 .0002 37.05 .0003))
+
+ (sax-fs4 '(.99 .0786 1.99 .1613 2.99 .0550 3.98 .0380 4.98 .0201 5.98 .0245 6.97 .0212
+ 7.96 .0069 8.96 .0130 9.96 .0029 10.95 .0084 11.95 .0093 12.94 .0026 13.94 .0015 14.93 .0022
+ 15.93 .0025 16.93 .0022 17.92 .0015 18.91 .0011 19.91 .0011 20.91 .0006 21.90 .0010 22.89 .0003
+ 23.89 .0003 24.89 .0004 25.89 .0003 26.88 .0011 26.95 .0003 27.87 .0003 28.87 .0012 29.87 .0002
+ 30.86 .0004 31.85 .0003 32.85 .0005 33.84 .0006 34.84 .0002 34.90 .0001))
+
+ (sax-g4 '(1.00 .0747 2.00 .1351 3.00 .0384 4.00 .0519 5.00 .0376 6.00 .0323 7.00 .0212
+ 8.00 .0091 9.00 .0086 10.00 .0060 11.00 .0132 12.00 .0038 13.00 .0016 14.00 .0044 15.00 .0023
+ 16.00 .0029 17.00 .0031 18.00 .0011 19.00 .0008 20.00 .0006 21.01 .0005 22.00 .0006 23.00 .0007
+ 24.00 .0008 25.01 .0003 26.01 .0017 27.00 .0012 28.00 .0005 29.03 .0001 30.00 .0004 31.00 .0005
+ 32.00 .0001 33.00 .0003 34.00 .0001))
+
+ (sax-gs4 '(1.00 .0671 1.99 .0676 2.98 .0664 3.97 .0207 4.97 .0170 5.96 .0406 6.96 .0157
+ 7.95 .0093 8.94 .0032 9.93 .0117 10.93 .0059 11.93 .0034 12.92 .0052 13.91 .0036 14.90 .0010
+ 15.89 .0023 16.89 .0019 17.89 .0011 18.88 .0013 19.87 .0009 20.86 .0005 21.86 .0006 22.86 .0011
+ 23.85 .0006 24.85 .0008 25.83 .0010 26.83 .0010 27.82 .0007 28.80 .0002 29.82 .0006 31.80 .0001))
+
+ (sax-a4 '(.99 .0707 1.99 .1376 2.99 .0767 3.98 .0191 4.98 .0316 5.97 .0241 6.97 .0070
+ 7.97 .0095 8.96 .0085 9.96 .0109 10.96 .0012 11.95 .0047 12.94 .0051 13.94 .0022 14.93 .0020
+ 15.93 .0007 16.93 .0016 17.92 .0014 18.92 .0008 19.92 .0005 20.91 .0008 21.91 .0005 22.91 .0002
+ 23.90 .0008 24.89 .0015 25.89 .0004 26.89 .0003 27.88 .0002 28.88 .0002 29.88 .0002))
+
+ (sax-as4 '(.99 .0652 1.98 .0768 2.97 .0399 3.96 .0314 4.95 .0539 5.94 .0282 6.93 .0048
+ 7.93 .0059 8.91 .0163 9.90 .0039 10.89 .0052 11.88 .0086 12.87 .0025 13.86 .0011 14.85 .0069
+ 15.84 .0006 16.84 .0018 17.82 .0008 18.80 .0004 19.81 .0004 20.78 .0002 21.79 .0010 22.78 .0038
+ 23.76 .0018 24.75 .0010 25.74 .0002 26.73 .0005 27.72 .0006 28.71 .0003))
+
+ (sax-b4 '(1.00 .1365 1.99 .0773 2.98 .0370 3.97 .0399 4.97 .0441 5.96 .0193 6.95 .0055
+ 7.95 .0036 8.94 .0106 9.93 .0050 10.93 .0075 11.92 .0047 12.91 .0013 13.90 .0034 14.90 .0024
+ 15.89 .0018 16.89 .0005 17.87 .0006 18.87 .0014 19.87 .0011 20.86 .0017 21.84 .0018 22.84 .0007
+ 23.83 .0003 24.82 .0006 25.83 .0002 26.81 .0002))
+
+ (sax-c5 '(.99 .1197 1.98 .0661 2.97 .0448 3.96 .0398 4.96 .0311 5.95 .0167 6.93 .0068
+ 7.93 .0249 8.92 .0065 9.91 .0104 10.90 .0081 11.89 .0032 12.88 .0060 13.87 .0037 14.86 .0020
+ 15.86 .0008 16.84 .0005 17.84 .0025 18.83 .0010 19.81 .0020 20.81 .0017 21.80 .0013 22.79 .0016
+ 23.78 .0009 24.77 .0006 25.76 .0002))
+
+ (sax-cs5 '(.98 .0251 1.97 .0316 2.95 .0599 3.93 .0403 4.92 .0418 5.90 .0065 6.89 .0047
+ 7.86 .0085 8.85 .0061 9.84 .0097 10.82 .0033 10.87 .0006 12.26 .0004 12.78 .0040 13.77 .0023
+ 14.75 .0020 15.73 .0003 16.72 .0011 17.71 .0012 18.69 .0013 19.67 .0008 20.66 .0013 21.64 .0005
+ 22.62 .0004 23.60 .0005))
+
+ (sax-d5 '(.99 .0055 1.97 .0823 2.95 .0106 3.94 .0646 4.93 .0345 5.91 .0069 6.90 .0201
+ 7.89 .0165 8.87 .0171 9.86 .0114 10.85 .0050 11.82 .0053 12.82 .0107 13.81 .0033 14.78 .0026
+ 15.78 .0016 16.76 .0019 17.74 .0011 18.72 .0030 19.73 .0009 20.70 .0021 21.67 .0003 22.67 .0003
+ 23.65 .0001))
+
+ (sax-ds5 '(.98 .0699 1.97 .0761 2.95 .0777 3.93 .0573 4.92 .0236 5.90 .0082 6.88 .0195
+ 7.87 .0108 8.85 .0205 9.83 .0042 10.82 .0112 11.80 .0039 12.78 .0018 13.77 .0027 14.75 .0017
+ 15.73 .0015 16.72 .0019 17.70 .0047 18.68 .0011 19.67 .0020 20.65 .0027 21.63 .0002))
+
+ (sax-e5 '(.99 .1082 1.99 .1222 2.99 .0874 3.98 .0436 4.98 .0208 5.98 .0141 6.97 .0193
+ 7.97 .0172 8.97 .0118 9.96 .0082 10.96 .0133 11.96 .0062 12.95 .0058 13.95 .0013 14.94 .0017
+ 15.94 .0029 16.94 .0032 17.93 .0006 18.93 .0028 19.92 .0004))
+
+ (sax-f5 '(1.00 .1462 2.00 .0665 3.01 .0741 4.01 .0382 5.01 .0262 6.02 .0172 7.02 .0168
+ 8.02 .0172 9.02 .0087 10.02 .0145 11.03 .0046 12.03 .0033 13.03 .0032 14.03 .0030 15.03 .0040
+ 16.04 .0059 17.04 .0026 18.04 .0005 19.05 .0009))
+
+ (sax-fs5 '(1.00 .0652 2.00 .0563 3.00 .0939 3.99 .0334 5.00 .0109 5.99 .0258 6.99 .0213
+ 7.99 .0135 8.99 .0018 9.99 .0205 10.99 .0043 11.99 .0004 12.99 .0037 13.98 .0017 14.98 .0071
+ 15.98 .0035 16.98 .0029 17.98 .0005))
+
+ (sax-g5 '(1.00 .0918 1.99 .0493 2.99 .0565 3.98 .0225 4.98 .0118 5.98 .0184 6.97 .0138
+ 7.99 .0042 8.98 .0077 9.95 .0104 10.96 .0018 11.94 .0022 12.98 .0061 13.96 .0032 14.96 .0023
+ 15.96 .0016 16.90 .0008))
+
+ (sax-gs5 '(.99 .1447 1.98 .0908 2.97 .0522 3.96 .0607 4.96 .0316 5.95 .0115 6.94 .0147
+ 7.93 .0148 8.92 .0221 9.91 .0097 10.90 .0087 11.90 .0078 12.89 .0127 13.88 .0042 14.87 .0007
+ 15.86 .0012))
+
+ (sax-a5 '(.97 .1089 1.94 .0491 4.85 .0162 5.82 .0156 6.78 .0130 7.75 .0174 8.72 .0104
+ 8.75 .0087 8.77 .0024 8.80 .0019 8.82 .0014 9.72 .0010 10.66 .0033 11.63 .0092 11.66 .0045
+ 12.59 .0028 12.65 .0015 12.67 .0011 13.64 .0007 14.56 .0017 14.59 .0017 14.61 .0010 14.62 .0008
+ 14.64 .0005 15.50 .0003 15.53 .0002 15.56 .0002 15.58 .0001))
+
+
+ ;; soprano sax?
+ (ssax-gs3 '(1.01 .0846 2.02 .0851 3.03 .0782 4.03 .0250 5.04 .0513 6.05 .0121 7.07 .0065
+ 8.08 .0409 9.09 .0134 10.09 .0032 11.10 .0168 12.12 .0076 13.13 .0054 14.13 .0091 15.14 .0078
+ 16.15 .0029 17.16 .0103 18.18 .0103 19.18 .0071 20.19 .0105 21.20 .0063 22.20 .0054 23.21 .0011
+ 24.22 .0008 25.24 .0003 26.23 .0001 27.26 .0002 28.25 .0006 29.27 .0004 30.29 .0008 31.29 .0004
+ 32.31 .0002 33.32 .0003 34.32 .0003 35.33 .0001 36.34 .0002 37.35 .0005 38.36 .0003 39.37 .0003
+ 40.37 .0002 41.39 .0002 42.40 .0002 43.41 .0002 44.43 .0001 45.43 .0007 46.43 .0004 47.44 .0002
+ 48.46 .0001 49.48 .0001 50.48 .0002 51.49 .0002 52.49 .0002 53.50 .0002 54.51 .0002 55.53 .0003
+ 56.54 .0003 57.54 .0002 58.55 .0002 59.55 .0001))
+
+ (ssax-a3 '(.99 .1143 1.99 .0599 2.99 .0780 3.99 .0629 4.99 .0063 5.99 .0066 6.99 .0283
+ 7.99 .0134 8.98 .0083 9.97 .0114 10.97 .0087 11.97 .0171 12.97 .0109 13.97 .0149 14.97 .0075
+ 15.97 .0164 16.97 .0174 17.94 .0021 18.97 .0139 19.96 .0073 20.95 .0122 21.95 .0018 22.95 .0022
+ 23.94 .0002 24.95 .0014 25.94 .0006 26.95 .0007 27.94 .0012 28.94 .0013 29.93 .0009 30.94 .0014
+ 31.92 .0012 32.93 .0008 33.93 .0015 34.93 .0021 35.92 .0009 36.93 .0011 37.93 .0011 38.94 .0005
+ 39.92 .0008 41.93 .0004 42.91 .0012 43.87 .0002 44.93 .0006 45.92 .0006 46.91 .0002 47.92 .0002
+ 48.91 .0004 49.89 .0004 50.89 .0003 51.89 .0003 52.90 .0003 53.90 .0003 54.91 .0003 55.90 .0003
+ 56.89 .0002))
+
+ (ssax-as3 '(1.00 .0772 1.99 .0797 2.98 .0350 3.99 .1086 4.98 .0418 5.97 .0170 6.98 .0247
+ 7.97 .0288 8.96 .0041 9.95 .0047 10.95 .0120 11.95 .0176 12.93 .0128 13.95 .0151 14.94 .0162
+ 15.92 .0152 16.93 .0077 17.93 .0111 18.92 .0092 19.91 .0079 20.91 .0053 21.89 .0009 22.90 .0008
+ 24.88 .0004 25.88 .0009 26.88 .0009 27.87 .0014 28.87 .0008 29.87 .0023 30.87 .0013 31.85 .0012
+ 32.87 .0015 33.85 .0011 34.85 .0024 35.84 .0021 36.86 .0024 37.87 .0008 38.82 .0007 39.85 .0009
+ 40.79 .0007 41.83 .0009 42.84 .0007 43.84 .0006 44.82 .0001 46.83 .0004 47.83 .0003 48.81 .0003
+ 49.82 .0002 50.82 .0001 51.82 .0002 52.81 .0002 54.81 .0004 55.80 .0002))
+
+ (ssax-b3 '(.99 .0413 1.98 .0949 2.98 .0746 3.96 .0636 4.96 .0383 5.95 .0300 6.93 .0190
+ 7.93 .0159 8.92 .0172 9.90 .0159 10.90 .0047 11.89 .0087 12.88 .0153 13.87 .0129 14.87 .0112
+ 15.85 .0054 16.84 .0076 17.84 .0060 18.82 .0064 19.81 .0050 20.81 .0009 21.80 .0013 22.78 .0003
+ 23.79 .0005 24.78 .0005 25.76 .0020 26.75 .0020 27.75 .0016 28.73 .0012 29.72 .0009 30.72 .0017
+ 31.70 .0018 32.69 .0012 33.69 .0022 34.67 .0014 35.67 .0015 36.66 .0009 37.65 .0013 38.64 .0019
+ 39.63 .0010 40.62 .0012 41.61 .0003 42.61 .0003 43.60 .0003 44.58 .0004 45.58 .0003 47.55 .0004
+ 48.54 .0002 49.54 .0003 50.53 .0002 51.52 .0002))
+
+ (ssax-c4 '(.99 .1251 1.98 .0932 2.97 .1614 3.97 .0801 4.96 .0100 5.94 .0183 6.94 .0221
+ 7.93 .0060 8.92 .0055 9.91 .0162 10.90 .0171 11.89 .0181 12.88 .0135 13.88 .0102 14.87 .0071
+ 15.86 .0066 16.84 .0071 17.83 .0057 18.83 .0027 19.82 .0006 20.82 .0008 21.80 .0003 22.78 .0007
+ 23.78 .0011 24.77 .0019 25.77 .0010 26.76 .0016 27.74 .0008 28.74 .0013 29.73 .0025 30.72 .0019
+ 31.71 .0029 32.70 .0022 33.69 .0011 34.68 .0014 35.68 .0010 36.67 .0014 37.65 .0007 38.64 .0005
+ 39.62 .0001 40.63 .0004 41.62 .0006 42.61 .0005 43.60 .0003 44.58 .0003 45.58 .0003 46.58 .0006
+ 47.57 .0003 48.56 .0002))
+
+ (ssax-cs4 '(.98 .0809 1.97 .0745 2.96 .1141 3.95 .0537 4.95 .0028 5.92 .0112 6.93 .0029
+ 7.90 .0117 8.89 .0101 9.89 .0091 10.87 .0113 11.86 .0048 12.85 .0076 13.84 .0054 14.82 .0089
+ 15.81 .0068 16.80 .0065 17.79 .0031 18.77 .0009 19.76 .0007 20.75 .0005 21.73 .0010 22.72 .0016
+ 23.71 .0009 24.70 .0016 25.68 .0010 26.68 .0018 27.66 .0018 28.65 .0009 29.64 .0012 30.63 .0017
+ 31.61 .0016 32.60 .0008 33.59 .0012 34.58 .0014 35.57 .0005 36.56 .0006 37.54 .0008 38.53 .0005
+ 39.52 .0004 40.50 .0004 41.49 .0001 42.47 .0004 43.46 .0002))
+
+ (ssax-d4 '(.99 .0919 1.98 .0711 2.98 .0924 3.97 .0396 4.95 .0407 5.94 .0357 6.93 .0035
+ 7.93 .0079 8.91 .0110 9.90 .0191 10.89 .0103 11.89 .0134 12.88 .0025 13.86 .0014 14.86 .0082
+ 15.85 .0084 16.84 .0024 17.82 .0011 18.82 .0011 19.81 .0010 20.80 .0002 21.79 .0015 22.78 .0011
+ 23.76 .0025 24.77 .0018 25.75 .0027 26.74 .0036 27.73 .0023 28.73 .0034 29.72 .0032 30.70 .0011
+ 31.70 .0017 32.69 .0014 33.68 .0013 34.66 .0004 35.65 .0003 36.64 .0002 37.63 .0002 38.62 .0004
+ 39.62 .0008 40.61 .0004 41.60 .0005 42.59 .0005 43.59 .0003 44.56 .0002))
+
+ (ssax-ds4 '(.99 .0684 1.98 .0744 2.97 .1315 3.96 .0137 4.94 .0352 5.94 .0195 6.93 .0148
+ 7.91 .0275 8.91 .0191 9.90 .0268 10.88 .0194 11.86 .0044 12.86 .0046 13.85 .0090 14.84 .0072
+ 15.83 .0049 16.82 .0015 17.80 .0017 18.80 .0006 19.79 .0008 20.77 .0020 21.76 .0010 22.75 .0025
+ 23.74 .0033 24.73 .0023 25.72 .0041 26.71 .0051 27.70 .0043 28.69 .0033 29.68 .0010 30.66 .0013
+ 31.65 .0013 32.64 .0013 33.63 .0008 34.64 .0001 35.61 .0002 36.60 .0003 37.62 .0002 38.58 .0006
+ 39.57 .0005 40.58 .0001 41.55 .0002))
+
+ (ssax-e4 '(1.00 .0363 1.98 .1101 2.98 .1009 3.96 .0168 4.95 .0610 5.95 .0099 6.94 .0066
+ 7.93 .0157 8.92 .0162 9.91 .0154 10.90 .0131 11.89 .0061 12.88 .0029 13.87 .0058 14.86 .0040
+ 15.85 .0015 16.84 .0012 17.84 .0005 18.82 .0005 19.81 .0008 20.85 .0007 21.80 .0005 22.78 .0016
+ 23.77 .0017 24.76 .0022 25.76 .0010 26.80 .0006 27.74 .0012 28.72 .0007 29.71 .0004 30.70 .0004
+ 31.69 .0001 32.68 .0001 33.67 .0003 34.65 .0004 35.65 .0003 36.64 .0003 37.63 .0002 38.61 .0002))
+
+ (ssax-f4 '(1.00 .0607 1.99 .1291 3.00 .0576 3.99 .0530 4.99 .0330 5.98 .0364 6.98 .0116
+ 7.98 .0252 8.97 .0175 9.97 .0166 10.97 .0147 11.97 .0096 12.96 .0060 13.96 .0022 14.95 .0018
+ 15.95 .0018 16.96 .0003 17.94 .0012 18.94 .0021 19.94 .0051 20.94 .0018 21.93 .0034 22.93 .0038
+ 23.93 .0035 24.92 .0041 25.92 .0015 26.91 .0024 27.92 .0019 28.92 .0008 29.91 .0005 30.92 .0003
+ 31.91 .0005 32.91 .0006 33.90 .0003 34.89 .0002 35.89 .0005 36.89 .0002))
+
+ (ssax-fs4 '(.99 .0502 1.98 .0678 2.96 .0319 3.95 .0589 4.93 .0093 5.93 .0072 6.91 .0063
+ 7.89 .0224 8.88 .0185 9.87 .0096 10.86 .0046 11.84 .0060 12.83 .0052 13.82 .0008 14.80 .0022
+ 15.79 .0009 16.79 .0008 17.76 .0011 18.75 .0024 19.74 .0013 20.71 .0009 21.71 .0038 22.70 .0037
+ 23.68 .0023 24.66 .0010 25.66 .0007 26.64 .0009 27.64 .0007 28.61 .0002 29.61 .0006 30.60 .0004
+ 31.58 .0008 32.56 .0004 33.55 .0005 35.53 .0002))
+
+ (ssax-g4 '(1.00 .0253 1.99 .0803 2.98 .0107 3.97 .0688 4.96 .0361 5.96 .0208 6.96 .0172
+ 7.95 .0172 8.94 .0189 9.93 .0080 10.92 .0114 11.92 .0059 12.91 .0058 13.90 .0007 14.89 .0011
+ 15.89 .0011 16.88 .0023 17.87 .0046 18.87 .0024 19.85 .0043 20.86 .0087 21.83 .0023 22.84 .0043
+ 23.84 .0039 24.83 .0020 25.81 .0017 26.81 .0009 27.82 .0006 28.80 .0004 29.79 .0007 30.80 .0005
+ 31.78 .0011 32.78 .0004 33.76 .0001))
+
+ (ssax-gs4 '(1.00 .0453 2.00 .1198 2.99 .0370 3.99 .1319 4.98 .0327 5.97 .0018 6.98 .0199
+ 7.97 .0362 8.97 .0196 9.96 .0065 10.96 .0061 11.96 .0025 12.95 .0026 13.95 .0010 14.94 .0005
+ 15.94 .0027 16.94 .0031 17.93 .0037 18.92 .0019 19.92 .0034 20.92 .0087 21.92 .0034 22.91 .0029
+ 23.91 .0024 24.90 .0006 25.90 .0002 26.90 .0009 27.90 .0003 28.90 .0015 29.89 .0011 30.89 .0004
+ 31.88 .0001))
+
+ (ssax-a4 '(1.00 .0568 1.99 .1275 2.98 .0496 3.98 .0504 4.97 .0277 5.96 .0064 6.95 .0205
+ 7.95 .0244 8.94 .0067 9.93 .0133 10.92 .0045 11.92 .0035 12.91 .0028 13.90 .0010 14.90 .0011
+ 15.89 .0035 16.89 .0034 17.88 .0037 18.87 .0052 19.86 .0027 20.86 .0028 21.86 .0003 22.84 .0011
+ 23.84 .0005 24.83 .0010 25.82 .0005 26.81 .0003 27.81 .0007 28.80 .0005 29.79 .0004))
+
+ (ssax-as4 '(.99 .0497 1.98 .0814 2.97 .0351 3.96 .0207 4.95 .0068 5.93 .0241 6.92 .0219
+ 7.91 .0187 8.90 .0053 9.88 .0026 10.88 .0026 11.87 .0027 12.85 .0011 13.85 .0018 14.84 .0029
+ 15.84 .0013 16.83 .0014 17.81 .0036 18.80 .0042 19.79 .0015 20.78 .0021 21.77 .0018 22.76 .0011
+ 23.75 .0004 24.66 .0003 25.73 .0006 26.72 .0005 27.71 .0002))
+
+ (ssax-b4 '(.99 .0161 1.98 .0825 2.96 .0846 3.95 .0304 4.94 .0112 5.93 .0158 6.91 .0362
+ 7.90 .0085 8.89 .0147 9.87 .0047 10.85 .0016 11.85 .0044 12.84 .0024 13.83 .0044 14.82 .0015
+ 15.80 .0066 16.79 .0061 17.78 .0135 18.77 .0107 19.75 .0020 20.75 .0008 21.73 .0010 22.71 .0014
+ 23.70 .0007 24.69 .0009 25.68 .0008 26.67 .0002))
+
+ (ssax-c5 '(1.00 .1378 1.99 .1932 2.99 .0181 3.98 .0213 4.97 .0472 5.97 .0302 6.97 .0099
+ 7.96 .0039 8.96 .0052 9.95 .0031 10.95 .0007 11.94 .0010 12.93 .0015 13.93 .0009 14.93 .0013
+ 15.92 .0018 16.92 .0015 17.91 .0030 18.91 .0013 19.90 .0008 20.90 .0008 21.89 .0006 22.89 .0006
+ 23.89 .0003))
+
+ (ssax-cs5 '(.99 .1332 1.97 .2232 2.96 .1240 3.95 .0080 4.94 .0398 5.93 .0194 6.92 .0059
+ 7.90 .0022 8.91 .0008 9.88 .0017 10.87 .0005 11.85 .0004 12.84 .0008 13.83 .0009 14.82 .0032
+ 15.81 .0009 16.81 .0017 17.78 .0009 18.77 .0003 19.76 .0002 20.75 .0006 21.74 .0004 22.73 .0002))
+
+ (ssax-d5 '(.99 .1242 1.98 .0414 2.97 .0487 3.96 .0182 4.95 .0225 5.94 .0112 6.93 .0012
+ 7.92 .0035 8.87 .0004 9.90 .0011 10.89 .0006 11.88 .0004 12.81 .0008 13.87 .0011 14.86 .0015
+ 15.84 .0005 16.83 .0002 17.82 .0005 18.46 .0002 19.82 .0002 20.81 .0002 21.66 .0001))
+
+ (ssax-ds5 '(.99 .1419 1.98 .0180 2.98 .0683 3.96 .0172 4.95 .0329 5.94 .0093 6.93 .0017
+ 7.91 .0014 8.91 .0022 9.90 .0018 10.88 .0004 11.89 .0011 12.88 .0009 13.87 .0010 14.83 .0007
+ 15.85 .0004 16.85 .0002 17.85 .0003 18.85 .0003 20.81 .0001))
+
+ (ssax-e5 '(1.00 .2435 1.99 .0422 2.99 .0422 3.98 .0137 4.97 .0155 5.97 .0127 6.96 .0024
+ 7.96 .0014 8.95 .0017 9.95 .0011 10.94 .0006 11.94 .0009 12.93 .0022 13.92 .0048 14.92 .0004
+ 15.91 .0006 16.91 .0003 17.90 .0002 18.89 .0002 19.89 .0002))
+
+ (ssax-f5 '(1.00 .2095 2.00 .0502 3.01 .0783 4.01 .0216 5.01 .0293 6.01 .0080 7.01 .0043
+ 8.02 .0036 9.02 .0019 10.02 .0002 11.02 .0013 12.02 .0010 13.02 .0007 14.03 .0010 15.03 .0003
+ 16.03 .0013 17.04 .0009 18.04 .0005))
+
+ (ssax-fs5 '(.99 .1379 1.98 .0339 2.98 .0480 3.97 .0340 4.96 .0264 5.95 .0126 6.94 .0046
+ 7.93 .0030 8.92 .0013 9.91 .0010 10.90 .0009 11.89 .0007 12.88 .0007 13.88 .0018 14.87 .0012
+ 15.86 .0006 16.85 .0004 17.84 .0007))
+
+ (ssax-g5 '(.99 .0699 1.98 .0273 2.96 .0227 3.95 .0133 4.94 .0151 5.92 .0023 6.92 .0024
+ 7.91 .0011 8.90 .0009 9.89 .0018 10.87 .0009 11.88 .0016 12.86 .0007 13.84 .0008 14.83 .0007
+ 15.82 .0005 16.81 .0003))
+
+ (ssax-gs5 '(1.00 .1830 1.99 .0897 2.99 .0456 3.99 .0296 4.99 .0125 5.98 .0059 6.98 .0105
+ 7.98 .0027 8.97 .0044 9.97 .0096 10.97 .0011 11.97 .0027 12.97 .0006 13.97 .0024 14.96 .0014
+ 15.95 .0002))
+
+ (ssax-a5 '(.99 .2010 1.98 .0677 2.97 .0195 3.97 .0363 4.96 .0191 5.95 .0092 6.94 .0047
+ 7.93 .0021 7.96 .0004 8.91 .0004 9.92 .0039 10.90 .0023 11.91 .0005 12.88 .0008 12.91 .0002
+ 13.86 .0002 14.87 .0007))
+
+ (ssax-as5 '(1.00 .1011 1.99 .0696 2.99 .0359 3.98 .0008 4.99 .0111 5.98 .0027 6.98 .0005
+ 7.98 .0038 8.98 .0032 9.98 .0037 10.97 .0024 11.97 .0012 12.97 .0009 13.97 .0004))
+
+ (ssax-b5 '(.98 .0933 1.95 .0632 2.93 .0226 4.89 .0036 5.86 .0133 6.84 .0018 7.82 .0036
+ 8.79 .0037 9.77 .0111 10.75 .0011 11.72 .0009 12.70 .0013))
+
+ (ssax-c6 '(1.01 .0218 1.98 .0033 3.00 .0037 3.99 .0010 4.03 .0009 4.77 .0002 4.95 .0002
+ 6.01 .0001 7.00 .0002 8.02 .0004 9.03 .0004 10.03 .0003 12.03 .0001))
+
+ (ssax-cs6 '(.99 .1143 1.99 .0478 2.99 .0259 3.97 .0101 4.97 .0058 5.96 .0010 6.95 .0012
+ 7.98 .0017 8.95 .0024 8.98 .0016 9.96 .0007 10.93 .0019 10.96 .0010 11.90 .0003 11.95 .0002))
+
+ (ssax-d6 '(1.01 .0247 2.02 .0062 3.02 .0036 4.03 .0052 5.05 .0006 6.07 .0004 7.06 .0013
+ 8.07 .0027 11.11 .0001))
+
+
+
+ (tbf-e2 '(1.01 .0028 2.00 .0192 3.04 .0188 4.02 .0134 5.02 .0319 6.05 .0335 7.04 .0136
+ 8.06 .0074 9.07 .0527 10.06 .0217 11.05 .0025 12.09 .0068 13.08 .0278 14.10 .0125 15.09 .0152
+ 16.13 .0101 17.13 .0088 18.11 .0094 19.14 .0084 20.20 .0008 21.13 .0031 22.16 .0097 23.14 .0053
+ 24.17 .0030 25.20 .0013 26.17 .0055 27.20 .0049 28.19 .0040 29.21 .0010 30.21 .0030 31.20 .0032
+ 32.24 .0031 33.21 .0006 34.23 .0015 35.25 .0020 36.23 .0012 37.25 .0010 38.29 .0007 39.26 .0017
+ 40.29 .0014 41.27 .0015 42.29 .0005 43.32 .0012 44.30 .0014 45.32 .0010 46.32 .0005 47.31 .0003
+ 48.34 .0009 49.32 .0005 50.34 .0005 51.35 .0001 52.35 .0005 53.37 .0006 54.37 .0006 55.38 .0001
+ 56.38 .0002 57.39 .0006 58.41 .0005 59.42 .0004 60.42 .0001 61.43 .0004 62.41 .0004 63.42 .0003
+ 64.45 .0002 65.46 .0001 66.45 .0003 67.48 .0003 68.46 .0001 69.50 .0001 70.49 .0004 71.48 .0002
+ 72.47 .0001 74.52 .0002 75.51 .0002 76.51 .0002 79.55 .0002 80.56 .0002 81.55 .0001 83.58 .0002
+ 84.57 .0001 85.59 .0002 87.60 .0002 88.59 .0001 89.61 .0002 92.62 .0001 93.64 .0001 96.67 .0001
+ 98.69 .0001))
+
+ (tbf-f2 '(.99 .0062 2.00 .0189 3.01 .0059 4.03 .0167 5.01 .0454 6.01 .0190 7.03 .0261
+ 8.04 .0495 9.04 .0195 10.01 .0059 11.02 .0030 12.05 .0247 13.04 .0097 14.05 .0122 15.04 .0076
+ 16.03 .0044 17.05 .0063 18.06 .0045 19.06 .0011 20.05 .0028 21.07 .0056 22.07 .0019 22.55 .0004
+ 23.17 .0001 24.07 .0026 25.08 .0016 26.10 .0017 27.11 .0006 28.09 .0011 29.10 .0014 30.10 .0011
+ 31.13 .0007 32.12 .0006 33.11 .0009 34.10 .0004 35.15 .0002 36.15 .0004 37.13 .0006 38.11 .0004
+ 39.11 .0002 40.15 .0003 41.13 .0004 42.13 .0003 43.17 .0002 44.20 .0002 45.16 .0002 46.18 .0003
+ 48.16 .0001 49.20 .0002 50.20 .0002 51.21 .0001 54.20 .0001))
+
+ (tbf-fs2 '(1.02 .0056 2.01 .0355 3.01 .0221 3.99 .0130 4.99 .0606 6.00 .0189 7.01 .0127
+ 8.02 .0612 9.01 .0211 10.01 .0079 10.99 .0134 11.99 .0205 13.00 .0282 14.03 .0114 15.02 .0079
+ 16.01 .0116 17.00 .0082 18.02 .0015 19.00 .0052 20.03 .0082 21.03 .0057 22.05 .0011 23.02 .0048
+ 24.01 .0035 25.01 .0032 26.02 .0012 27.04 .0033 28.01 .0015 29.03 .0013 30.05 .0008 31.03 .0024
+ 32.02 .0010 33.02 .0007 34.05 .0007 35.05 .0013 36.04 .0008 37.03 .0004 38.02 .0004 39.03 .0008
+ 40.03 .0005 42.07 .0005 43.05 .0006 44.05 .0003 45.10 .0002 46.05 .0003 47.05 .0003 48.05 .0002
+ 50.08 .0003 51.07 .0003 52.06 .0002 53.09 .0001 54.00 .0001 55.06 .0002 56.09 .0002 57.10 .0001
+ 58.08 .0001 59.05 .0001 60.09 .0001 62.09 .0001 63.06 .0001 66.13 .0001))
+
+ (tbf-g2 '(.99 .0059 1.98 .0515 2.98 .0305 3.98 .0081 4.97 .0448 5.98 .0160 6.97 .0397
+ 7.97 .0418 8.93 .0079 9.96 .0086 10.95 .0358 11.96 .0207 12.94 .0116 13.94 .0070 14.93 .0156
+ 15.94 .0120 16.98 .0013 17.94 .0060 18.91 .0074 19.94 .0070 20.94 .0013 21.92 .0060 22.91 .0043
+ 23.89 .0014 24.95 .0017 25.91 .0031 26.90 .0022 27.90 .0009 28.91 .0017 29.89 .0016 30.88 .0012
+ 31.86 .0004 32.88 .0013 33.89 .0008 34.85 .0005 35.83 .0005 36.85 .0008 37.87 .0006 38.87 .0001
+ 39.86 .0004 40.90 .0008 41.86 .0005 42.88 .0003 43.86 .0005 44.84 .0005 45.89 .0003 46.92 .0002
+ 47.86 .0003 48.77 .0002 49.85 .0002 50.86 .0002 51.81 .0003 52.88 .0001 53.87 .0001 54.80 .0002
+ 55.77 .0001 56.88 .0002 58.76 .0001 59.82 .0001 62.83 .0001 63.88 .0001 73.81 .0001))
+
+ (tbf-gs2 '(.99 .0058 1.98 .0327 2.99 .0282 3.99 .0353 4.98 .0348 5.96 .0451 6.97 .0549
+ 7.97 .0183 8.96 .0096 9.94 .0221 10.94 .0110 11.93 .0102 12.92 .0074 13.92 .0109 14.91 .0080
+ 15.15 .0013 15.91 .0003 16.90 .0034 17.88 .0030 18.88 .0036 19.14 .0004 20.05 .0003 20.86 .0029
+ 21.87 .0014 22.84 .0008 23.85 .0021 24.83 .0011 25.81 .0007 26.80 .0003 27.81 .0010 28.82 .0003
+ 29.84 .0003 30.77 .0006 31.75 .0002 32.78 .0005 33.79 .0003 34.77 .0003 35.78 .0003 37.75 .0002
+ 38.72 .0002 41.75 .0001 42.73 .0001 45.69 .0001))
+
+ (tbf-a2 '(1.00 .0085 1.99 .0291 2.99 .0151 4.00 .0554 5.00 .0164 6.02 .0087 7.00 .0365
+ 8.06 .0023 9.02 .0098 9.98 .0165 10.97 .0176 11.97 .0107 12.98 .0081 13.97 .0077 14.97 .0012
+ 15.99 .0038 16.98 .0028 17.97 .0017 18.97 .0024 19.98 .0014 20.95 .0017 21.92 .0009 23.01 .0009
+ 23.98 .0006 24.94 .0004 25.95 .0013 26.95 .0003 27.99 .0002 28.97 .0006 29.96 .0002 30.90 .0003
+ 31.89 .0003 32.83 .0002 33.02 .0001 33.78 .0001 34.94 .0001 35.94 .0002 38.91 .0002 39.88 .0001))
+
+ (tbf-as2 '(1.00 .0251 2.05 .0009 3.02 .0385 4.03 .0997 5.03 .0337 6.04 .1061 7.04 .0539
+ 8.05 .0357 9.06 .0635 10.06 .0233 11.05 .0153 12.07 .0218 13.07 .0235 14.08 .0092 15.08 .0135
+ 16.09 .0104 17.09 .0055 18.10 .0130 19.11 .0059 20.12 .0030 21.12 .0060 22.12 .0029 23.12 .0032
+ 24.13 .0022 25.14 .0016 26.14 .0007 27.15 .0032 28.15 .0014 29.16 .0012 30.15 .0015 31.18 .0011
+ 32.19 .0008 33.18 .0014 34.19 .0007 35.19 .0003 36.18 .0009 37.16 .0004 39.21 .0007 40.22 .0006
+ 41.23 .0001 42.20 .0004 43.24 .0007 45.25 .0007 46.26 .0004 47.32 .0001 48.26 .0004 49.26 .0003
+ 51.29 .0003 52.28 .0002 54.30 .0003 55.32 .0002 57.31 .0002 58.32 .0001 60.31 .0002 61.30 .0001
+ 63.35 .0001 64.34 .0001 66.37 .0001))
+
+ (tbf-b2 '(1.02 .0294 2.03 .0276 3.03 .0170 4.05 .0409 5.06 .0434 6.06 .0552 7.06 .0128
+ 8.08 .0076 9.07 .0216 10.08 .0169 11.07 .0035 12.09 .0094 13.10 .0046 14.12 .0021 15.12 .0059
+ 16.13 .0023 17.15 .0039 18.16 .0035 19.17 .0015 20.18 .0020 21.19 .0023 22.19 .0005 23.22 .0022
+ 24.24 .0010 25.27 .0006 26.26 .0008 27.27 .0010 28.28 .0003 29.28 .0006 30.27 .0005 31.32 .0003
+ 32.30 .0004 33.29 .0004 35.37 .0004 36.34 .0002 37.38 .0002 38.38 .0003 39.48 .0002 41.43 .0003
+ 42.40 .0001 44.50 .0001 45.47 .0001 47.46 .0001))
+
+ (tbf-c3 '(1.01 .0167 2.00 .0116 3.00 .0033 3.99 .0432 5.01 .0116 6.00 .0573 7.00 .0128
+ 8.00 .0582 9.02 .0354 10.01 .0203 11.00 .0226 12.00 .0167 13.03 .0055 14.02 .0174 15.01 .0088
+ 16.01 .0083 17.03 .0066 18.03 .0022 19.01 .0058 20.01 .0049 21.03 .0016 22.03 .0053 23.03 .0028
+ 24.01 .0013 25.03 .0028 26.03 .0015 27.00 .0003 28.02 .0026 28.39 .0002 29.70 .0002 30.03 .0014
+ 31.03 .0010 32.04 .0007 33.03 .0010 34.03 .0007 35.04 .0004 36.03 .0009 37.03 .0004 38.05 .0006
+ 39.04 .0008 40.03 .0003 41.04 .0004 42.04 .0005 43.06 .0003 44.02 .0004 45.03 .0002 46.08 .0001
+ 47.05 .0004 48.03 .0002 49.06 .0001 50.05 .0003 51.06 .0002 52.07 .0002 53.04 .0002 54.05 .0001
+ 55.05 .0002 56.05 .0001 58.05 .0002 59.06 .0001 61.05 .0002))
+
+ (tbf-cs3 '(1.00 .0192 1.98 .0300 2.99 .0565 3.98 .0329 4.97 .0791 5.98 .0457 6.96 .0053
+ 7.95 .0405 8.96 .0260 9.95 .0146 10.93 .0283 11.95 .0038 12.93 .0205 13.92 .0086 14.93 .0028
+ 15.91 .0069 16.91 .0030 17.91 .0095 18.89 .0058 19.90 .0023 20.89 .0048 21.87 .0015 22.89 .0033
+ 23.88 .0021 24.87 .0003 25.87 .0030 26.86 .0014 27.85 .0016 28.86 .0021 29.85 .0005 30.83 .0019
+ 31.84 .0014 32.83 .0005 33.82 .0012 34.82 .0006 35.81 .0008 36.82 .0011 37.81 .0004 38.78 .0004
+ 39.80 .0005 40.79 .0004 41.77 .0007 42.77 .0002 43.78 .0004 44.76 .0005 45.77 .0003 46.76 .0003
+ 47.75 .0002 48.75 .0002 49.75 .0005 50.74 .0002 51.73 .0002 52.73 .0002 53.72 .0002 54.73 .0003
+ 55.70 .0001 56.70 .0001 57.71 .0003 58.71 .0001 59.70 .0002 60.70 .0001 61.69 .0002 62.69 .0003
+ 64.67 .0001 65.67 .0001 67.64 .0001 69.65 .0001 70.63 .0001 75.62 .0001))
+
+ (tbf-d3 '(1.01 .0462 2.01 .0592 3.00 .1127 3.99 .0398 5.00 .1221 6.02 .0099 7.01 .0396
+ 8.01 .0429 9.00 .0249 10.00 .0223 10.27 .0015 11.03 .0010 12.01 .0146 13.01 .0097 14.00 .0008
+ 15.00 .0064 16.01 .0020 17.02 .0066 18.02 .0043 19.02 .0021 20.01 .0035 21.02 .0009 22.02 .0022
+ 23.03 .0022 24.00 .0007 25.02 .0025 26.02 .0002 27.03 .0017 27.30 .0003 28.73 .0002 29.03 .0016
+ 30.02 .0012 31.02 .0006 32.04 .0013 33.04 .0005 34.02 .0006 35.01 .0004 36.03 .0007 37.03 .0009
+ 38.05 .0003 39.05 .0006 40.04 .0003 41.04 .0003 42.04 .0005 43.05 .0002 44.06 .0003 45.05 .0001
+ 46.05 .0002 47.04 .0003 48.06 .0002 49.06 .0003 50.06 .0001 51.06 .0001 52.04 .0001 53.06 .0001
+ 54.06 .0002 57.06 .0001 58.07 .0001 59.06 .0002 66.09 .0001))
+
+ (tbf-ds3 '(1.00 .0462 2.01 .0546 3.03 .1220 4.04 .0672 5.06 .0575 6.07 .0310 7.08 .0402
+ 8.09 .0228 9.09 .0345 10.10 .0204 11.11 .0134 12.12 .0171 13.13 .0056 14.15 .0087 15.16 .0035
+ 16.17 .0068 17.18 .0027 18.18 .0061 19.20 .0018 20.20 .0037 21.22 .0030 22.24 .0013 23.24 .0028
+ 23.58 .0004 24.91 .0002 25.26 .0031 26.26 .0008 27.27 .0022 28.28 .0021 29.29 .0013 30.31 .0017
+ 31.31 .0006 32.34 .0015 33.34 .0008 34.35 .0012 35.36 .0012 36.36 .0008 37.37 .0012 38.38 .0006
+ 39.40 .0008 40.39 .0002 41.43 .0004 42.44 .0003 43.45 .0004 44.45 .0004 45.45 .0004 46.46 .0006
+ 47.46 .0002 48.48 .0004 49.47 .0002 50.52 .0003 51.52 .0002 52.53 .0003 53.53 .0003 54.54 .0002
+ 55.55 .0003 57.58 .0002 58.58 .0001 59.60 .0002 60.60 .0002 61.62 .0002 62.63 .0002 63.62 .0001
+ 64.64 .0002 66.67 .0001 68.68 .0001 69.70 .0001 71.70 .0001))
+
+ (tbf-e3 '(1.00 .0427 2.02 .0329 3.03 .0739 4.03 .0442 5.05 .0547 6.06 .0547 7.06 .0357
+ 8.07 .0307 9.09 .0344 10.10 .0088 11.10 .0255 12.12 .0049 13.13 .0161 14.13 .0032 15.14 .0087
+ 16.16 .0028 17.15 .0054 18.17 .0018 19.18 .0048 20.20 .0025 21.19 .0033 22.21 .0032 23.22 .0009
+ 24.22 .0017 25.25 .0004 26.24 .0011 26.54 .0002 27.27 .0002 28.26 .0012 28.54 .0002 29.26 .0001
+ 30.29 .0009 31.29 .0003 32.30 .0007 33.32 .0005 34.32 .0007 35.32 .0005 36.35 .0004 37.36 .0004
+ 38.38 .0002 39.37 .0004 41.39 .0004 42.42 .0001 43.40 .0002 45.43 .0002 47.45 .0002 48.45 .0001
+ 49.46 .0001 50.48 .0002 51.49 .0001 52.49 .0001 54.52 .0001 56.54 .0001))
+
+ (tbf-f3 '(1.01 .0430 2.02 .0658 3.02 .0533 4.02 .1351 5.04 .0653 6.03 .0900 7.05 .0410
+ 8.05 .0344 9.07 .0169 10.07 .0220 11.08 .0159 12.08 .0180 13.08 .0045 14.09 .0098 15.08 .0023
+ 16.10 .0022 17.12 .0040 18.12 .0030 19.13 .0031 20.14 .0014 21.14 .0019 22.15 .0012 23.16 .0015
+ 24.16 .0007 25.16 .0010 26.17 .0009 27.19 .0009 28.19 .0004 29.20 .0009 30.19 .0002 31.21 .0007
+ 32.23 .0003 33.23 .0005 35.24 .0004 36.33 .0001 37.25 .0003 38.26 .0002 39.27 .0003 41.29 .0002
+ 42.29 .0001 43.30 .0002 45.31 .0001 46.33 .0001))
+
+ (tbf-fs3 '(1.00 .0676 1.99 .0337 3.00 .0651 4.00 .0928 4.99 .0773 6.00 .0359 6.99 .0266
+ 7.99 .0183 9.00 .0246 9.99 .0092 10.98 .0144 11.99 .0027 12.98 .0112 13.98 .0019 14.99 .0058
+ 15.97 .0010 16.97 .0024 17.98 .0033 18.97 .0025 19.97 .0024 20.98 .0018 21.97 .0030 22.98 .0013
+ 23.97 .0026 24.19 .0004 24.97 .0003 25.97 .0026 26.96 .0003 27.96 .0018 28.97 .0006 29.96 .0012
+ 30.96 .0012 31.97 .0011 32.96 .0012 33.95 .0006 34.96 .0008 35.95 .0003 36.95 .0009 37.95 .0002
+ 38.95 .0005 39.95 .0002 40.95 .0005 41.95 .0003 42.95 .0005 43.95 .0002 44.94 .0003 45.95 .0003
+ 46.94 .0001 47.94 .0002 49.94 .0003 50.94 .0001 51.94 .0003 53.93 .0002 55.93 .0002 56.93 .0001
+ 57.93 .0002 58.93 .0001 59.93 .0001 60.93 .0001 62.93 .0001 64.91 .0001))
+
+ (tbf-g3 '(1.01 .1108 2.02 .0159 3.03 .0749 4.03 .0774 5.05 .0554 6.06 .0287 7.06 .0529
+ 8.08 .0167 9.09 .0172 10.09 .0181 11.10 .0072 12.12 .0148 13.11 .0028 14.13 .0060 15.14 .0012
+ 16.14 .0047 17.15 .0034 18.17 .0009 19.17 .0041 20.18 .0007 21.20 .0016 22.20 .0011 23.21 .0022
+ 24.23 .0010 25.24 .0008 26.24 .0015 27.25 .0003 28.26 .0011 29.26 .0009 30.28 .0009 31.29 .0007
+ 32.29 .0002 33.31 .0005 34.32 .0001 35.32 .0006 36.33 .0002 37.35 .0003 38.34 .0004 40.37 .0003
+ 42.39 .0002 43.40 .0002 44.40 .0001 45.41 .0002 47.44 .0002 50.47 .0001 52.48 .0001 54.49 .0001))
+
+ (tbf-gs3 '(1.01 .0962 2.01 .0925 3.01 .0770 4.03 .0479 5.03 .1190 6.03 .0237 7.03 .0168
+ 8.05 .0283 9.05 .0100 10.05 .0292 11.06 .0097 12.07 .0103 13.07 .0121 14.07 .0042 15.08 .0012
+ 16.09 .0051 17.09 .0023 18.09 .0058 19.11 .0009 20.11 .0029 21.11 .0028 22.12 .0011 23.13 .0028
+ 24.12 .0013 25.13 .0016 26.14 .0014 27.14 .0009 28.15 .0016 29.16 .0007 30.16 .0007 31.16 .0010
+ 32.17 .0004 33.18 .0006 34.18 .0005 35.18 .0003 36.19 .0006 37.20 .0003 38.20 .0003 39.21 .0004
+ 40.22 .0002 41.22 .0004 42.23 .0001 43.23 .0002 44.24 .0002 46.25 .0003 47.25 .0001 48.26 .0002
+ 49.26 .0001 51.28 .0001 54.29 .0001))
+
+ (tbf-a3 '(.99 .0880 1.99 .1784 2.99 .0966 3.99 .0789 4.99 .0440 5.99 .0574 6.99 .0067
+ 7.99 .0384 8.98 .0270 9.98 .0089 10.97 .0152 11.97 .0039 12.97 .0092 13.97 .0081 14.97 .0020
+ 15.97 .0030 16.96 .0051 17.96 .0014 18.96 .0031 19.96 .0026 20.95 .0004 21.95 .0028 22.95 .0006
+ 23.94 .0012 24.94 .0021 25.94 .0009 26.94 .0010 27.94 .0010 28.94 .0006 29.94 .0008 30.93 .0009
+ 31.93 .0001 32.92 .0007 33.92 .0005 34.91 .0002 35.92 .0005 36.91 .0003 37.92 .0002 38.92 .0004
+ 40.91 .0002 41.90 .0002 43.89 .0002 44.89 .0002 46.89 .0001 49.89 .0001 52.88 .0001))
+
+ (tbf-as3 '(1.00 .0084 2.02 .2204 3.02 .1914 4.03 .0999 5.03 .0302 6.04 .0574 7.04 .0432
+ 8.05 .0168 9.05 .0414 10.06 .0213 11.06 .0024 12.07 .0063 13.08 .0058 14.08 .0014 15.09 .0031
+ 16.09 .0067 17.10 .0026 18.10 .0026 19.11 .0039 20.11 .0016 21.12 .0015 22.12 .0032 23.13 .0017
+ 24.13 .0010 25.14 .0020 26.14 .0016 27.15 .0002 28.16 .0013 29.16 .0009 31.17 .0009 32.18 .0008
+ 33.18 .0004 34.19 .0005 35.19 .0008 36.20 .0002 37.20 .0004 38.21 .0005 39.21 .0002 40.22 .0002
+ 41.22 .0003 42.23 .0002 43.23 .0001 44.24 .0002 45.25 .0001 47.26 .0002 48.26 .0001 50.28 .0001
+ 51.28 .0001))
+
+ (tbf-b3 '(1.00 .0475 2.00 .1146 3.01 .1513 4.01 .0759 5.00 .0441 6.01 .0348 7.01 .0462
+ 8.01 .0291 9.02 .0056 10.02 .0281 11.01 .0178 12.02 .0016 13.02 .0054 14.02 .0082 15.03 .0051
+ 16.02 .0014 17.02 .0053 18.03 .0050 19.03 .0017 20.03 .0024 21.04 .0037 22.03 .0025 23.03 .0008
+ 24.04 .0028 25.04 .0023 26.04 .0007 27.04 .0007 28.04 .0018 29.04 .0017 30.05 .0003 31.04 .0011
+ 32.04 .0013 33.05 .0004 34.05 .0005 35.05 .0009 36.06 .0007 37.05 .0002 38.06 .0004 39.06 .0006
+ 40.06 .0004 41.07 .0003 42.06 .0005 43.06 .0004 44.07 .0001 45.07 .0003 46.07 .0003 47.08 .0001
+ 48.07 .0001 49.07 .0003 50.08 .0002 52.08 .0001 53.08 .0001))
+
+ (tbf-c4 '(1.01 .0092 2.01 .0918 3.01 .1218 4.03 .1524 5.03 .0561 6.03 .0196 7.05 .0312
+ 8.05 .0481 9.05 .0292 10.07 .0048 11.07 .0035 12.07 .0096 13.08 .0079 14.09 .0040 15.09 .0017
+ 16.09 .0054 17.11 .0080 18.11 .0039 19.11 .0010 20.13 .0034 21.13 .0028 22.13 .0027 23.14 .0004
+ 24.15 .0015 25.15 .0024 26.16 .0021 27.17 .0006 28.17 .0008 29.17 .0013 30.19 .0015 31.19 .0005
+ 32.19 .0002 33.21 .0009 34.21 .0010 35.21 .0006 36.23 .0003 37.23 .0005 38.23 .0009 39.24 .0007
+ 40.25 .0002 41.25 .0004 42.26 .0006 43.27 .0004 44.27 .0002 45.27 .0003 46.29 .0004 47.29 .0003
+ 48.29 .0001))
+
+ (tbf-cs4 '(1.00 .0881 2.00 .1170 3.00 .0852 4.00 .0643 5.00 .0778 6.00 .0489 6.99 .0269
+ 8.00 .0107 8.99 .0292 10.00 .0159 10.99 .0082 12.00 .0066 12.99 .0009 14.00 .0050 14.99 .0064
+ 15.99 .0059 17.00 .0044 17.99 .0024 19.00 .0042 19.99 .0040 21.00 .0027 21.99 .0023 22.99 .0018
+ 23.99 .0024 24.99 .0025 25.99 .0019 26.99 .0007 27.99 .0004 28.99 .0012 29.99 .0014 30.99 .0012
+ 31.99 .0004 32.99 .0002 33.99 .0007 34.98 .0009 35.99 .0008 36.98 .0005 37.99 .0002 38.98 .0005
+ 39.99 .0007 40.98 .0007 41.98 .0004 42.98 .0001 43.98 .0003 44.99 .0004 45.98 .0003))
+
+ (tbf-d4 '(1.01 .1228 2.02 .1247 3.02 .1142 4.03 .0474 5.04 .0335 6.04 .0332 7.05 .0302
+ 8.06 .0222 9.07 .0090 10.08 .0030 11.09 .0027 12.09 .0054 13.10 .0059 14.10 .0040 15.11 .0038
+ 16.12 .0029 17.13 .0011 18.14 .0020 19.15 .0021 20.15 .0023 21.16 .0016 22.17 .0012 23.17 .0008
+ 24.18 .0003 25.19 .0006 26.20 .0008 27.21 .0008 28.22 .0008 29.22 .0004 30.23 .0002 31.23 .0002
+ 32.24 .0003 33.26 .0004 34.26 .0004 35.27 .0004 36.28 .0002 39.29 .0002 40.30 .0002 41.32 .0001))
+
+ (tbf-ds4 '(1.01 .1133 2.01 .1562 3.02 .1429 4.02 .0366 5.02 .0219 6.03 .0212 7.03 .0142
+ 8.04 .0216 9.04 .0101 10.04 .0063 11.05 .0076 12.05 .0081 13.06 .0050 14.06 .0030 15.07 .0010
+ 16.07 .0011 17.07 .0019 18.08 .0022 19.08 .0029 20.09 .0028 21.09 .0021 22.09 .0016 23.10 .0016
+ 24.10 .0010 25.11 .0005 26.11 .0003 27.11 .0002 28.12 .0006 29.12 .0004 30.13 .0005 31.13 .0004
+ 32.13 .0006 33.14 .0003 34.14 .0003 35.15 .0002 37.15 .0002 38.15 .0001 39.16 .0002 40.16 .0002
+ 41.17 .0002))
+
+ (tbf-e4 '(.99 .0906 1.99 .1338 2.99 .1235 3.98 .0833 4.98 .0601 5.98 .0264 6.98 .0126
+ 7.97 .0051 8.97 .0026 9.97 .0014 10.96 .0018 11.96 .0025 12.96 .0031 13.96 .0021 14.95 .0034
+ 15.95 .0035 16.95 .0037 17.94 .0031 18.94 .0021 19.93 .0021 20.93 .0016 21.92 .0010 22.92 .0012
+ 23.92 .0011 24.91 .0007 25.91 .0004 26.91 .0002 28.91 .0001 30.89 .0001 31.90 .0002 32.90 .0002
+ 33.89 .0002 34.89 .0002 35.88 .0002 36.88 .0002 37.88 .0002 38.87 .0001))
+
+ (tbf-f4 '(1.01 .1228 2.01 .3008 3.01 .1922 4.01 .0927 5.01 .0581 6.02 .0447 7.02 .0207
+ 8.03 .0106 9.02 .0057 10.02 .0018 11.03 .0040 12.03 .0041 13.04 .0040 14.04 .0039 15.04 .0042
+ 16.04 .0034 17.05 .0035 18.05 .0038 19.06 .0033 20.06 .0029 21.06 .0024 22.06 .0020 23.07 .0018
+ 24.07 .0015 25.07 .0012 26.07 .0009 27.07 .0006 28.08 .0005 29.08 .0003 30.09 .0003 31.10 .0003
+ 32.10 .0004 33.11 .0004 34.11 .0004 35.10 .0004 36.10 .0004 37.11 .0003 38.11 .0002))
+
+ (tbf-fs4 '(1.01 .0765 2.01 .2561 3.02 .0803 4.03 .0653 5.03 .0230 6.04 .0093 7.05 .0035
+ 8.05 .0042 9.06 .0040 10.07 .0052 11.07 .0056 12.08 .0049 13.09 .0039 14.09 .0035 15.10 .0031
+ 16.10 .0021 17.11 .0012 18.12 .0010 19.12 .0005 20.13 .0003 21.14 .0001 22.14 .0001 23.15 .0003
+ 24.16 .0002 25.16 .0003 26.17 .0003 27.18 .0003 28.18 .0003 29.19 .0003 30.20 .0002 31.20 .0001))
+
+ (tbf-g4 '(1.01 .0092 2.02 .2167 3.02 .0668 4.02 .0254 5.03 .0210 6.04 .0282 7.04 .0151
+ 8.05 .0130 9.05 .0054 10.06 .0031 11.07 .0014 12.08 .0020 13.08 .0020 14.09 .0020 15.09 .0021
+ 16.10 .0015 17.10 .0007 18.11 .0003 19.13 .0002 20.13 .0004 21.13 .0005 22.14 .0004 23.14 .0003
+ 24.15 .0003 25.15 .0001 29.18 .0001 30.19 .0001))
+
+ (tbf-gs4 '(1.00 .1758 2.01 .1249 3.01 .0253 4.02 .0471 5.02 .0478 6.03 .0217 7.03 .0025
+ 8.04 .0044 9.05 .0066 10.05 .0060 11.05 .0030 12.06 .0021 13.09 .0005 14.07 .0008 15.07 .0014
+ 16.08 .0010 17.08 .0005 18.10 .0002 19.09 .0003 20.10 .0003 21.10 .0003 22.10 .0001 24.13 .0001
+ 25.13 .0001 26.13 .0001))
+
+ (tbf-a4 '(1.00 .3944 2.01 .1441 3.00 .0979 4.01 .0595 5.01 .0218 6.01 .0057 7.01 .0131
+ 8.01 .0053 9.01 .0018 10.02 .0029 11.01 .0042 12.02 .0032 13.01 .0001 14.02 .0014 15.02 .0017
+ 16.02 .0006 17.03 .0003 18.02 .0006 19.03 .0009 20.03 .0003 21.04 .0002 22.03 .0004 23.03 .0004
+ 25.04 .0002 26.04 .0003 27.04 .0001))
+
+ (tbf-as4 '(1.01 .3895 2.03 .1550 3.03 .0985 4.05 .0153 5.06 .0280 6.07 .0103 7.08 .0028
+ 8.10 .0069 9.10 .0023 10.12 .0025 11.13 .0029 12.14 .0011 13.15 .0011 14.16 .0009 15.17 .0002
+ 16.19 .0007 17.20 .0004 18.22 .0002 19.22 .0003 20.23 .0001 22.26 .0001))
+
+ (tbf-b4 '(1.00 .2165 2.01 .1597 3.00 .0717 4.01 .0353 5.01 .0332 6.01 .0024 7.01 .0088
+ 8.02 .0009 9.02 .0039 10.02 .0016 11.02 .0015 12.02 .0014 13.03 .0003 14.03 .0007 16.03 .0004
+ 17.04 .0002 18.03 .0002 19.04 .0001))
+
+ (tbf-c5 '(1.01 .1699 2.01 .2670 3.03 .0349 4.03 .0454 5.05 .0024 6.05 .0069 7.06 .0021
+ 8.07 .0015 9.08 .0011 10.09 .0007 11.09 .0007 12.10 .0001 13.11 .0004 15.13 .0002))
+
+ (tbf-cs5 '(1.00 .2017 2.00 .0920 3.00 .0598 3.99 .0086 4.99 .0120 5.99 .0063 6.99 .0034
+ 7.99 .0029 8.99 .0008 9.99 .0014 10.98 .0008 11.97 .0007 12.98 .0006 13.96 .0001 14.97 .0003
+ 15.97 .0001))
+
+
+ (tbp-e2 '(1.00 .0179 2.00 .0770 2.99 .0532 3.99 .0183 4.97 .0494 5.98 .0137 6.95 .0121
+ 7.97 .0153 8.94 .0012 9.96 .0040 10.97 .0030 11.93 .0021 12.93 .0034 13.94 .0007 14.91 .0004
+ 16.01 .0002 16.93 .0003 17.92 .0008 18.94 .0004 19.96 .0002 21.00 .0001 22.95 .0001 25.89 .0001))
+
+ (tbp-f2 '(.99 .0137 2.01 .0473 3.03 .0362 4.01 .0117 5.02 .0565 6.04 .0247 7.06 .0348
+ 8.04 .0251 9.05 .0143 10.07 .0146 11.09 .0020 12.07 .0048 13.09 .0013 14.12 .0012 15.12 .0009
+ 16.12 .0004 17.10 .0010 18.11 .0003 19.13 .0004 20.13 .0001 22.14 .0001 24.17 .0001))
+
+ (tbp-fs2 '(1.02 .0110 2.02 .0470 3.02 .0038 4.02 .0343 5.01 .0442 6.02 .0198 7.01 .0600
+ 8.02 .0144 9.05 .0468 10.05 .0112 11.05 .0137 12.05 .0078 13.05 .0041 14.05 .0040 15.05 .0012
+ 16.05 .0018 17.05 .0007 18.08 .0011 19.08 .0003 20.09 .0005 21.08 .0004 22.08 .0002 23.07 .0003
+ 25.07 .0001))
+
+ (tbp-g2 '(1.01 .0148 2.00 .0544 3.02 .0144 4.01 .0848 5.03 .0334 6.02 .0703 7.01 .0546
+ 8.03 .0242 9.02 .0235 10.04 .0054 11.02 .0079 12.04 .0009 13.03 .0032 14.02 .0011 15.04 .0013
+ 16.02 .0005 17.06 .0005 18.01 .0001 19.01 .0002 20.07 .0002 21.08 .0001))
+
+ (tbp-gs2 '(.99 .0357 2.00 .0505 3.00 .0158 3.99 .0999 4.99 .0473 6.00 .0633 7.00 .0187
+ 7.98 .0536 8.99 .0153 9.99 .0238 10.98 .0049 11.98 .0045 12.99 .0018 13.98 .0031 14.97 .0011
+ 15.97 .0009 16.98 .0005 17.97 .0007 18.97 .0006 19.95 .0003 20.96 .0001))
+
+ (tbp-a2 '(1.00 .0295 1.99 .1044 2.98 .0380 3.96 .1223 4.95 .0652 5.93 .0906 6.93 .0212
+ 7.91 .0492 8.91 .0034 9.88 .0180 10.87 .0036 11.86 .0050 12.85 .0005 13.85 .0016 14.84 .0009
+ 15.81 .0014 16.80 .0002 17.77 .0003 20.73 .0001 21.73 .0002 22.73 .0002 24.70 .0001))
+
+ (tbp-as2 '(1.00 .0228 2.01 .0987 3.02 .0160 4.03 .0517 5.03 .0818 6.04 .0522 7.06 .0447
+ 8.06 .0171 9.07 .0228 10.06 .0032 11.08 .0065 12.06 .0008 13.09 .0023 14.11 .0008 15.09 .0004
+ 16.11 .0004 17.10 .0003 18.13 .0002 20.07 .0001))
+
+ (tbp-b2 '(1.01 .0076 1.99 .0810 2.98 .0345 3.98 .0341 4.99 .0653 5.99 .0085 6.96 .0538
+ 7.97 .0030 8.97 .0204 9.96 .0059 10.95 .0026 11.96 .0028 12.96 .0006 13.94 .0014 14.92 .0002
+ 15.94 .0007 16.95 .0002))
+
+ (tbp-c3 '(1.02 .0300 2.02 .0703 3.03 .1222 4.04 .0495 5.04 .0810 6.04 .0372 7.05 .0371
+ 8.06 .0353 9.08 .0026 10.09 .0078 11.10 .0065 12.11 .0027 13.11 .0030 14.12 .0006 15.12 .0013
+ 16.13 .0006 17.14 .0002 18.16 .0002 19.18 .0001 20.19 .0001 21.19 .0001))
+
+ (tbp-cs3 '(.99 .0466 1.97 .0094 2.97 .0953 3.95 .0427 4.96 .0520 5.94 .0187 6.94 .0127
+ 7.92 .0075 8.90 .0015 9.90 .0017 10.88 .0009 11.89 .0002 12.85 .0002))
+
+ (tbp-d3 '(1.01 .0634 2.02 .0187 3.02 .0987 4.02 .0742 5.02 .0182 6.03 .0331 7.03 .0132
+ 8.03 .0025 9.04 .0026 10.06 .0016 11.07 .0002 12.08 .0001))
+
+ (tbp-ds3 '(1.01 .1106 2.01 .0100 3.00 .0866 4.00 .0859 5.00 .0217 6.00 .0251 6.99 .0134
+ 7.99 .0022 8.99 .0026 9.99 .0021 11.00 .0005 14.99 .0001 16.99 .0001))
+
+ (tbp-e3 '(1.00 .1452 1.99 .0464 2.98 .0553 3.97 .1114 4.96 .0181 5.95 .0077 6.94 .0033
+ 7.93 .0043 8.92 .0023 9.92 .0003 10.90 .0006 11.89 .0003 14.88 .0001 15.87 .0002 19.83 .0001))
+
+ (tbp-f3 '(.99 .0923 2.00 .0191 3.00 .0745 3.99 .1014 5.00 .0547 6.00 .0129 6.99 .0032
+ 8.00 .0023 9.00 .0018 9.98 .0007 10.38 .0001 12.98 .0001))
+
+ (tbp-fs3 '(1.01 .0781 2.00 .0346 2.99 .0441 4.01 .0196 5.00 .0310 5.99 .0213 7.00 .0062
+ 7.99 .0021 9.00 .0003 9.99 .0002))
+
+ (tbp-g3 '(1.01 .0733 2.03 .0883 3.03 .0772 4.05 .0148 5.06 .0055 6.06 .0033 7.09 .0026
+ 8.09 .0015 9.11 .0003 10.12 .0002))
+
+ (tbp-gs3 '(1.02 .0885 2.03 .1115 3.05 .0480 4.06 .0466 5.07 .0106 6.09 .0018 7.10 .0009))
+
+ (tbp-a3 '(1.01 .1416 2.02 .1418 3.02 .0683 4.03 .0464 5.04 .0178 6.04 .0037 7.06 .0018
+ 8.07 .0006 9.05 .0004))
+
+ (tbp-as3 '(1.01 .1361 2.01 .0839 3.00 .0761 4.00 .0211 5.00 .0045 6.00 .0018 7.00 .0004))
+
+ (tbp-b3 '(1.01 .0960 2.01 .0594 3.01 .0315 4.01 .0078 5.01 .0021 6.01 .0009 7.02 .0005
+ 8.03 .0003))
+
+ (tbp-c4 '(1.00 .0855 2.00 .1172 3.00 .0276 4.00 .0135 5.00 .0053 6.00 .0021 6.99 .0003))
+
+ (tbp-cs4 '(1.01 .0033 2.00 .0982 2.99 .0491 3.99 .0185 4.99 .0043 5.98 .0004 6.99 .0001))
+
+ (tbp-d4 '(1.01 .0485 2.01 .1552 3.01 .0547 4.01 .0136 5.03 .0026 6.04 .0010 7.05 .0001))
+
+ (tbp-ds4 '(1.01 .0030 2.01 .1892 3.01 .0563 4.01 .0025 5.02 .0034 5.97 .0001 7.03 .0003))
+
+ (tbp-e4 '(1.01 .0508 2.02 .0934 3.02 .0147 4.03 .0111 5.05 .0014 6.06 .0014 8.08 .0001))
+
+ (tbp-f4 '(1.00 .0260 2.02 .2047 3.02 .0550 4.03 .0165 5.04 .0051 6.04 .0005 7.05 .0002))
+
+ (tbp-fs4 '(1.02 .0971 2.03 .0635 3.04 .0254 4.05 .0023 5.07 .0002 6.08 .0003 7.09 .0001))
+
+ (tbp-g4 '(1.02 .3176 2.03 .0734 3.04 .0332 4.05 .0152 5.06 .0048 6.08 .0007))
+
+ (tbp-gs4 '(1.01 .3321 2.01 .1320 3.01 .0072 4.02 .0028 5.03 .0009 6.04 .0002 7.04 .0002))
+
+ (tbp-a4 '(1.00 .5149 2.00 .2025 3.00 .0392 3.99 .0117 4.99 .0035 5.99 .0008 6.99 .0002
+ 7.98 .0001))
+
+ (tbp-as4 '(1.01 .3188 2.01 .2130 3.02 .0427 4.03 .0024 5.05 .0004 6.05 .0007 7.06 .0002
+ 8.06 .0002))
+
+ (tbp-b4 '(1.00 .1685 1.99 .0732 2.99 .0056 3.99 .0042 4.99 .0009 5.99 .0005))
+
+ (tbp-c5 '(1.01 .3386 2.02 .0634 3.02 .0212 4.03 .0019 5.04 .0004))
+
+ (tbp-cs5 '(1.00 .2958 2.00 .0843 3.01 .0058 4.01 .0027 5.01 .0003))
+
+ (tbp-d5 '(1.00 .4237 2.01 .0453 3.01 .0045 4.02 .0007 5.02 .0004))
+
+ ;; trumpet
+ (trp-fs3 '(1.01 .0533 2.03 .0559 3.05 .0505 4.06 .0542 5.08 .0382 6.10 .0570 7.12 .0321
+ 8.14 .0393 9.15 .0277 10.17 .0157 11.19 .0165 12.20 .0152 13.22 .0081 14.23 .0089 15.24 .0035
+ 16.26 .0045 17.28 .0052 18.29 .0020 19.31 .0021 20.33 .0017 21.35 .0014 22.37 .0010 23.38 .0009
+ 24.40 .0004 25.42 .0005 26.44 .0004 27.45 .0004 28.46 .0004 29.48 .0002 30.49 .0002 31.51 .0002
+ 32.53 .0001 33.55 .0001))
+
+ (trp-g3 '(.99 .0459 1.99 .0931 3.00 .0517 4.00 .0496 5.00 .0576 6.00 .0452 7.00 .0263
+ 8.00 .0125 9.01 .0131 10.01 .0136 11.00 .0066 12.00 .0081 13.00 .0032 14.00 .0039 14.99 .0026
+ 16.00 .0017 16.99 .0017 17.99 .0009 19.01 .0013 20.01 .0008 21.01 .0006 22.00 .0006 23.00 .0003
+ 24.01 .0004 25.01 .0003 26.01 .0002 27.02 .0002 28.02 .0001 29.02 .0001 31.04 .0001))
+
+ (trp-gs3 '(.99 .0455 1.99 .0969 2.97 .0487 3.97 .0296 4.97 .0186 5.95 .0219 6.95 .0075
+ 7.94 .0176 8.93 .0202 9.93 .0175 10.91 .0156 11.91 .0097 12.91 .0066 13.89 .0065 14.89 .0051
+ 15.88 .0037 16.86 .0015 17.87 .0016 18.85 .0010 19.85 .0006 20.84 .0006 21.84 .0006 22.84 .0005
+ 23.82 .0003 24.82 .0003 25.80 .0002 26.79 .0002 27.79 .0001 28.79 .0001))
+
+ (trp-a3 '(.99 .0420 1.99 .0954 2.99 .0579 3.99 .0722 4.98 .0813 5.98 .0399 6.98 .0379
+ 7.98 .0181 8.98 .0188 9.98 .0147 10.97 .0100 11.97 .0091 12.96 .0048 13.96 .0091 14.96 .0048
+ 15.96 .0016 16.96 .0027 17.97 .0020 18.96 .0014 19.96 .0007 20.95 .0007 21.95 .0006 22.94 .0003
+ 23.95 .0005 24.95 .0002 25.95 .0002 26.95 .0002 27.96 .0002 28.95 .0002 29.94 .0001))
+
+ (trp-as3 '(1.01 .0487 2.01 .0236 3.01 .0599 4.01 .0397 5.01 .0525 6.01 .0426 7.00 .0144
+ 8.01 .0134 9.01 .0274 10.01 .0087 11.01 .0041 12.00 .0052 13.01 .0080 14.01 .0028 15.02 .0022
+ 16.01 .0014 17.04 .0005 18.04 .0003 19.03 .0005 20.02 .0003 21.02 .0003 22.02 .0003 23.03 .0002
+ 24.03 .0002 25.02 .0001))
+
+ (trp-b3 '(1.00 .0534 2.00 .0362 3.00 .0698 4.00 .0793 4.99 .0301 6.00 .0216 7.00 .0130
+ 8.00 .0151 9.00 .0172 10.00 .0062 11.00 .0041 11.99 .0022 13.00 .0017 14.00 .0012 14.99 .0013
+ 15.95 .0002 16.99 .0001 18.00 .0003 19.00 .0003 20.00 .0003 21.01 .0001))
+
+ (trp-c4 '(1.01 .0410 2.03 .0543 3.03 .0487 4.04 .0354 5.05 .0408 6.06 .0221 7.08 .0099
+ 8.09 .0248 9.09 .0107 10.11 .0037 11.11 .0087 12.13 .0035 13.14 .0012 14.16 .0013 15.17 .0002
+ 16.18 .0002 17.19 .0003 18.20 .0002 19.21 .0002 20.22 .0002 21.23 .0001 22.24 .0001))
+
+ (trp-cs4 '(1.01 .0199 2.03 .0437 3.03 .0142 4.04 .0534 5.04 .0310 6.06 .0194 7.06 .0124
+ 8.06 .0071 9.07 .0061 10.06 .0037 11.09 .0022 12.12 .0007 13.11 .0005 14.12 .0003 15.10 .0002
+ 16.12 .0002 17.13 .0001 18.13 .0001))
+
+ (trp-d4 '(1.01 .0320 2.02 .0510 3.04 .0747 4.05 .0619 5.06 .0404 6.07 .0195 7.08 .0221
+ 8.09 .0112 9.11 .0073 10.13 .0031 11.13 .0026 12.15 .0017 13.16 .0013 14.17 .0009 15.18 .0007
+ 16.18 .0004 17.19 .0003 18.22 .0002 19.23 .0002 20.23 .0002 21.25 .0001))
+
+ (trp-ds4 '(1.00 .0471 2.01 .0466 3.02 .0304 4.02 .0166 5.02 .0187 6.02 .0086 7.03 .0064
+ 8.03 .0067 9.03 .0033 10.02 .0016 11.05 .0013 12.06 .0008 13.06 .0005 14.05 .0002 15.04 .0002
+ 16.05 .0002 17.05 .0001))
+
+ (trp-e4 '(1.01 .0365 2.01 .0352 3.02 .0462 4.02 .0230 5.02 .0092 6.02 .0078 7.02 .0059
+ 8.04 .0034 9.04 .0011 10.05 .0010 11.07 .0003 12.07 .0003 13.06 .0002 14.06 .0001 15.07 .0001))
+
+ (trp-f4 '(1.00 .0412 2.00 .0621 3.00 .0180 3.99 .0631 4.99 .0245 5.99 .0369 6.99 .0093
+ 7.99 .0126 8.99 .0027 9.99 .0035 10.99 .0021 11.99 .0016 12.99 .0010 13.98 .0009 14.98 .0006
+ 15.98 .0004 16.98 .0002))
+
+ (trp-fs4 '(.99 .0581 1.98 .0494 2.98 .0614 3.97 .0316 4.96 .0151 5.96 .0095 6.95 .0022
+ 7.93 .0022 8.93 .0013 9.94 .0008 10.93 .0003 11.92 .0002 12.92 .0001 13.93 .0001))
+
+ (trp-g4 '(1.00 .0979 1.99 .0344 2.99 .0374 3.99 .0179 4.98 .0148 5.98 .0059 6.98 .0029
+ 7.95 .0005 8.97 .0004 9.97 .0002 10.96 .0002))
+
+ (trp-gs4 '(1.00 .0670 2.00 .0138 3.00 .0100 4.01 .0076 4.99 .0070 5.99 .0037 6.97 .0023
+ 7.97 .0007 8.97 .0002 9.98 .0001 10.97 .0002))
+
+ (trp-a4 '(1.00 .0403 2.01 .0211 3.00 .0107 4.00 .0052 4.99 .0022 6.00 .0013 7.00 .0006
+ 8.01 .0002 9.02 .0001 10.03 .0001))
+
+ (trp-as4 '(1.00 .0128 2.01 .0154 3.00 .0269 3.99 .0098 4.99 .0021 5.98 .0016 6.99 .0004
+ 8.00 .0003 9.02 .0002))
+
+ (trp-b4 '(1.01 .0287 2.01 .0583 3.01 .0386 4.00 .0098 5.01 .0068 6.02 .0012 7.02 .0012
+ 8.03 .0003 9.02 .0003 10.01 .0001))
+
+ (trp-c5 '(1.01 .0190 2.01 .0057 3.01 .0039 4.01 .0051 5.03 .0005 6.02 .0002 7.03 .0001))
+
+ (trp-cs5 '(1.01 .0087 2.01 .0050 3.01 .0011 4.01 .0002))
+
+ (trp-d5 '(1.01 .0145 2.01 .0098 3.01 .0013 4.01 .0003))
+
+ (trp-ds5 '(1.00 .0231 2.00 .0053 2.98 .0077 3.97 .0021 4.96 .0003 6.98 .0001))
+
+ (trp-e5 '(1.01 .0520 2.02 .0187 3.00 .0009 4.04 .0011 5.02 .0001))
+
+ (trp-f5 '(1.02 .0332 2.02 .0074 3.03 .0031))
+
+ (trp-fs5 '(1.01 .1718 2.02 .1098 3.02 .0288 4.02 .0047 5.04 .0026 6.04 .0008 7.06 .0004
+ 8.06 .0002))
+
+ (trp-g5 '(1.02 .0825 2.03 .0364 3.04 .0160 4.06 .0045 5.07 .0011 6.09 .0005 7.10 .0002))
+
+ (trp-gs5 '(1.02 .0114 2.02 .0346 3.02 .0045 4.04 .0013 5.06 .0002))
+
+ (trp-a5 '(1.02 .0821 2.03 .0089 3.04 .0023 4.06 .0003 5.05 .0001))
+
+ (trp-as5 '(1.01 .1554 2.01 .0287 3.02 .0084 4.02 .0035 5.03 .0007 6.04 .0002 7.04 .0001))
+
+ (trp-b5 '(1.01 .0559 2.01 .0017 3.01 .0013 4.02 .0001))
+
+ (trp-c6 '(1.01 .0291 2.00 .0150 3.01 .0032 4.02 .0004 5.02 .0002))
+
+
+
+ (trpf-fs3 '(1.00 .0292 1.99 .0424 3.00 .0242 4.00 .0413 4.99 .0315 6.00 .0454 7.00 .0143
+ 7.98 .0108 8.99 .0077 9.99 .0084 10.99 .0071 11.98 .0078 12.97 .0085 13.98 .0032 14.97 .0035
+ 15.97 .0052 16.96 .0021 17.96 .0033 18.96 .0024 19.97 .0016 20.95 .0015 21.95 .0011 22.95 .0006
+ 23.95 .0007 24.94 .0006 25.94 .0004 26.94 .0003 27.93 .0004 28.93 .0003 29.93 .0002 30.92 .0003
+ 31.92 .0001 32.93 .0001 33.91 .0002))
+
+ (trpf-g3 '(.99 .0286 1.97 .0669 2.95 .0456 3.95 .0345 4.94 .0617 5.91 .0341 6.90 .0225
+ 7.89 .0264 8.88 .0155 9.86 .0160 10.84 .0150 11.83 .0085 12.82 .0112 13.80 .0054 14.78 .0042
+ 15.77 .0056 16.76 .0023 17.73 .0027 18.71 .0010 19.73 .0014 20.69 .0014 21.68 .0007 22.67 .0007
+ 23.64 .0007 24.63 .0004 25.62 .0005 26.59 .0003 27.62 .0002 28.56 .0003 29.55 .0001 30.53 .0002
+ 31.51 .0002 32.50 .0001 33.48 .0002 35.47 .0001))
+
+ (trpf-gs3 '(.99 .0306 1.99 .0608 2.97 .0495 3.97 .0557 4.97 .0228 5.95 .0337 6.95 .0177
+ 7.94 .0112 8.92 .0146 9.93 .0022 10.91 .0069 11.89 .0053 12.89 .0047 13.88 .0031 14.87 .0063
+ 15.87 .0042 16.86 .0033 17.84 .0031 18.84 .0028 19.83 .0018 20.83 .0015 21.82 .0010 22.80 .0010
+ 23.80 .0005 24.79 .0007 25.77 .0004 26.77 .0005 27.76 .0003 28.75 .0003 29.74 .0002 30.74 .0002
+ 32.73 .0001))
+
+ (trpf-a3 '(.99 .0331 2.00 .0607 3.00 .0463 4.00 .0350 5.00 .0480 6.00 .0294 7.00 .0318
+ 7.99 .0150 8.98 .0166 9.98 .0148 10.98 .0109 11.99 .0052 13.02 .0012 13.99 .0070 14.98 .0054
+ 15.98 .0035 16.97 .0035 17.96 .0021 18.96 .0019 19.96 .0008 20.96 .0010 21.97 .0006 22.96 .0005
+ 23.96 .0007 24.96 .0004 25.95 .0006 26.95 .0004 27.94 .0003 28.94 .0002 29.94 .0001 30.94 .0002
+ 31.93 .0002 32.93 .0001))
+
+ (trpf-as3 '(1.00 .0250 2.00 .0182 2.99 .0170 3.97 .0199 4.97 .0223 5.97 .0224 6.95 .0094
+ 7.95 .0070 8.94 .0069 9.92 .0064 10.91 .0030 11.92 .0028 12.90 .0024 13.01 .0007 14.00 .0003
+ 14.89 .0008 15.89 .0007 16.91 .0002 17.88 .0002 18.86 .0001 20.83 .0001))
+
+ (trpf-b3 '(1.00 .0379 1.99 .0221 2.99 .0480 3.99 .0721 4.97 .0322 5.98 .0203 6.97 .0220
+ 7.97 .0170 8.96 .0150 9.96 .0042 10.95 .0040 11.93 .0049 12.94 .0038 14.00 .0011 14.95 .0021
+ 15.95 .0008 16.93 .0004 16.98 .0004 17.90 .0004 18.00 .0003 18.99 .0003 19.89 .0003 20.88 .0003
+ 21.89 .0002 22.97 .0002 23.97 .0002))
+
+ (trpf-c4 '(1.01 .0330 2.02 .0365 3.02 .0430 4.03 .0164 5.05 .0234 6.04 .0138 7.05 .0110
+ 8.06 .0202 9.07 .0098 10.08 .0030 11.09 .0065 12.11 .0027 13.11 .0009 14.13 .0014 15.15 .0003
+ 16.12 .0002 17.13 .0002 18.12 .0002 19.14 .0002 20.13 .0002 21.14 .0001))
+
+ (trpf-cs4 '(1.01 .0082 2.02 .0191 3.02 .0152 4.01 .0324 5.02 .0129 6.03 .0050 7.01 .0093
+ 8.01 .0031 9.01 .0036 10.00 .0017 11.01 .0010 12.00 .0004 13.02 .0004 14.03 .0003 15.02 .0002
+ 16.03 .0001))
+
+ (trpf-d4 '(1.01 .0190 2.03 .0431 3.04 .0481 4.05 .0399 5.07 .0179 6.08 .0198 7.09 .0136
+ 8.10 .0081 9.12 .0041 10.10 .0011 11.15 .0016 12.16 .0014 13.17 .0007 14.18 .0005 15.20 .0003
+ 16.20 .0002 17.22 .0002 19.24 .0001))
+
+ (trpf-ds4 '(1.00 .0239 2.01 .0207 3.02 .0113 4.00 .0083 5.00 .0145 5.97 .0054 6.99 .0031
+ 7.98 .0026 8.97 .0027 9.98 .0010 11.01 .0004 11.99 .0004 13.00 .0003 13.97 .0002 14.98 .0002
+ 15.97 .0002))
+
+ (trpf-e4 '(1.02 .0134 2.03 .0124 3.04 .0117 4.05 .0041 5.08 .0007 6.06 .0009 7.08 .0006
+ 8.06 .0002 9.11 .0002))
+
+ (trpf-f4 '(1.03 .0045 2.03 .0019 3.03 .0006 4.04 .0012 5.02 .0004 6.08 .0001))
+
+ (trpf-fs4 '(1.00 .0501 2.00 .0385 3.00 .0509 3.99 .0156 4.98 .0099 5.98 .0063 6.99 .0017
+ 7.97 .0020 8.97 .0017 9.96 .0012 10.96 .0004 11.95 .0004 12.97 .0001 13.94 .0002))
+
+ (trpf-g4 '(1.00 .0998 2.00 .0632 3.01 .0506 4.01 .0395 5.00 .0265 6.01 .0137 7.01 .0058
+ 8.01 .0017 9.02 .0010 10.02 .0007 11.02 .0007 12.03 .0004 13.03 .0004 14.03 .0002 15.05 .0001))
+
+ (trpf-gs4 '(1.00 .0589 2.00 .0237 2.99 .0208 3.98 .0103 4.98 .0087 5.98 .0053 6.97 .0039
+ 7.98 .0017 8.98 .0006 10.00 .0003 10.97 .0002 12.00 .0001))
+
+ (trpf-a4 '(1.01 .0482 2.01 .0264 3.02 .0127 4.01 .0108 5.01 .0039 6.01 .0012 7.00 .0012
+ 8.01 .0004 9.02 .0002 10.02 .0002 11.00 .0001))
+
+ (trpf-as4 '(1.00 .0176 2.01 .0156 3.00 .0312 3.99 .0057 5.00 .0055 5.99 .0036 6.99 .0007
+ 7.99 .0005 8.99 .0003 9.99 .0001 10.99 .0001))
+
+ (trpf-b4 '(1.01 .0051 1.99 .0340 2.98 .0087 3.97 .0121 4.97 .0018 5.94 .0018 6.95 .0005
+ 7.93 .0002 8.94 .0004))
+
+ (trpf-c5 '(1.01 .0110 1.99 .0059 3.00 .0200 3.99 .0059 5.00 .0016 5.99 .0005 6.98 .0002
+ 7.96 .0002 8.99 .0002))
+
+ (trpf-cs5 '(1.01 .0257 2.01 .0215 3.02 .0022 4.00 .0027 5.01 .0007 6.00 .0007 7.02 .0002))
+
+ (trpf-d5 '(1.01 .0616 2.01 .0423 3.01 .0140 4.01 .0061 4.99 .0034 5.99 .0008 6.98 .0006
+ 8.00 .0003 8.97 .0002))
+
+ (trpf-ds5 '(.99 .0763 1.99 .0800 2.98 .0329 3.97 .0255 4.96 .0110 5.95 .0041 6.95 .0018
+ 7.94 .0006 8.93 .0005 9.90 .0002 9.93 .0002 10.91 .0002))
+
+ (trpf-e5 '(1.01 .0196 2.00 .0085 2.98 .0039 3.97 .0007 4.98 .0003))
+
+ (trpf-f5 '(1.02 .0735 2.03 .0526 3.04 .0168 4.05 .0064 5.07 .0009 6.07 .0008 7.09 .0002
+ 8.09 .0001 9.12 .0001))
+
+ (trpf-fs5 '(1.01 .1101 2.02 .0477 3.03 .0090 4.04 .0024 5.05 .0012 6.06 .0015 7.07 .0004
+ 8.08 .0002))
+
+ (trpf-g5 '(1.02 .1148 2.03 .0215 3.04 .0185 4.06 .0077 5.07 .0023 6.08 .0007 7.09 .0004
+ 8.12 .0002))
+
+ (trpf-gs5 '(1.01 .0538 2.02 .0584 3.03 .0156 4.04 .0028 5.06 .0009 6.07 .0006 7.07 .0002))
+
+ (trpf-a5 '(1.01 .1885 2.02 .0789 3.04 .0214 4.05 .0086 5.06 .0049 6.07 .0010 7.08 .0007
+ 8.10 .0003 9.11 .0003 10.12 .0001 11.13 .0001))
+
+ (trpf-as5 '(1.01 .0233 2.02 .0033 3.01 .0008 4.03 .0002))
+
+ (trpf-b5 '(1.00 .1077 2.01 .0158 3.01 .0039 4.01 .0011 5.01 .0003 6.02 .0002 7.02 .0001))
+
+ (trpf-c6 '(1.01 .0873 2.02 .0519 3.03 .0156 4.04 .0042 5.04 .0019 6.05 .0006 7.06 .0004
+ 8.07 .0002))
+
+ (trpf-cs6 '(1.01 .0852 2.02 .0049 3.03 .0007 4.05 .0001))
+
+ ;; violin?
+ (vl-g3 '(.99 .0159 1.99 .1898 3.00 .0499 3.99 .0352 5.00 .0192 6.00 .0100 7.00 .0173
+ 8.00 .0142 8.99 .0045 10.01 .0178 11.00 .0108 12.00 .0081 12.99 .0254 13.99 .0074 14.99 .0062
+ 16.00 .0122 17.00 .0049 17.99 .0022 19.01 .0041 20.01 .0048 21.01 .0037 22.01 .0016 23.01 .0001
+ 24.00 .0002 25.00 .0006 26.00 .0010 27.00 .0015 28.03 .0004 29.02 .0007 30.01 .0006 32.00 .0002
+ 33.01 .0001 34.00 .0001 35.01 .0004 36.02 .0003 37.02 .0001 40.02 .0001 40.99 .0002 42.01 .0003
+ 48.01 .0001 51.01 .0001))
+
+ (vl-gs3 '(.99 .0185 1.99 .1881 2.97 .0463 3.97 .0528 4.97 .0309 5.95 .0316 6.95 .0104
+ 7.93 .0422 8.94 .0114 9.90 .0018 10.92 .0088 11.89 .0021 12.90 .0077 13.91 .0044 14.86 .0029
+ 14.93 .0028 15.91 .0011 16.88 .0082 17.89 .0022 18.88 .0043 19.86 .0024 20.84 .0012 21.84 .0007
+ 22.87 .0008 23.85 .0006 24.84 .0004 25.82 .0010 26.81 .0006 27.81 .0012 28.79 .0002 29.78 .0002
+ 30.77 .0001 31.78 .0003 33.75 .0001 34.76 .0002 35.75 .0002 36.75 .0002 37.77 .0001 40.74 .0001))
+
+ (vl-a3 '(.99 .0215 2.00 .1550 2.99 .0293 4.00 .0298 5.00 .0211 6.00 .0389 7.00 .0057
+ 7.99 .0235 8.99 .0172 9.99 .0040 11.00 .0026 12.00 .0074 12.99 .0065 13.99 .0192 14.99 .0026
+ 15.98 .0063 16.99 .0045 18.01 .0036 18.99 .0050 20.00 .0012 20.98 .0011 21.99 .0007 22.99 .0014
+ 23.99 .0003 25.00 .0011 26.00 .0008 26.99 .0007 27.98 .0002 28.99 .0001 29.97 .0004 31.00 .0002
+ 31.99 .0002 32.99 .0002 33.98 .0001 35.03 .0001 36.00 .0002 36.98 .0003 37.99 .0002 38.99 .0001
+ 39.99 .0002 41.01 .0001 41.99 .0001 43.04 .0001 43.99 .0001))
+
+ (vl-as3 '(1.00 .0210 2.00 .1015 3.00 .0450 3.99 .0210 4.99 .0266 6.00 .0143 7.00 .0661
+ 7.99 .0367 8.99 .0149 9.99 .0037 10.99 .0344 11.99 .0069 12.99 .0110 13.98 .0088 14.98 .0052
+ 15.98 .0066 16.99 .0038 17.98 .0027 18.98 .0007 19.98 .0018 20.98 .0009 21.99 .0011 22.99 .0013
+ 23.99 .0006 24.97 .0004 25.98 .0001 26.98 .0003 27.97 .0002 28.99 .0002 29.97 .0002 31.00 .0002
+ 31.97 .0004 32.97 .0001 33.99 .0003 34.97 .0002 35.97 .0003 36.94 .0001 37.99 .0001 38.96 .0001
+ 41.97 .0001))
+
+ (vl-b3 '(1.00 .0532 1.99 .0205 3.00 .0342 3.99 .0312 5.00 .0493 5.99 .0062 6.99 .0103
+ 7.99 .0240 8.99 .0134 9.99 .0046 10.98 .0154 11.99 .0077 12.98 .0084 13.99 .0028 14.99 .0026
+ 15.98 .0054 16.98 .0031 17.99 .0004 18.98 .0009 19.99 .0005 20.52 .0001 21.98 .0011 22.97 .0010
+ 23.99 .0004 24.96 .0003 26.00 .0001 27.99 .0006 28.99 .0001 30.97 .0003 32.00 .0002 32.99 .0001
+ 33.97 .0002 36.99 .0001))
+
+ (vl-c4 '(.99 .1156 2.00 .0827 3.00 .0458 4.00 .0163 5.00 .0256 6.01 .0103 7.02 .0032
+ 8.00 .0025 8.98 .0056 10.00 .0072 10.98 .0016 11.98 .0036 13.02 .0013 14.00 .0021 15.00 .0024
+ 15.99 .0013 16.99 .0003 18.01 .0001 19.01 .0003 19.99 .0001 21.02 .0001 22.03 .0002 29.00 .0001))
+
+ (vl-cs4 '(1.00 .3269 2.00 .0869 2.99 .0386 4.00 .0117 4.99 .0062 6.00 .0264 7.00 .0099
+ 8.00 .0038 9.01 .0040 10.00 .0057 11.03 .0040 12.02 .0017 13.00 .0009 14.02 .0026 15.02 .0009
+ 15.95 .0002 16.99 .0002 18.01 .0001 19.01 .0005 20.00 .0001 21.03 .0002 22.03 .0001))
+
+ (vl-d4 '(1.00 .2473 2.00 .0621 2.98 .0073 3.99 .0178 5.00 .0070 5.98 .0041 7.02 .0054
+ 8.01 .0114 9.05 .0034 10.05 .0024 10.93 .0003 11.99 .0011 13.00 .0011 14.03 .0010 15.01 .0002
+ 15.96 .0001 17.02 .0001 18.01 .0005 21.00 .0001 22.00 .0002))
+
+ (vl-ds4 '(1.00 .0394 2.00 .0358 2.99 .0119 3.99 .0208 4.99 .0064 5.98 .0126 6.96 .0028
+ 7.03 .0017 8.01 .0006 8.92 .0005 9.97 .0048 10.97 .0004 11.99 .0005 12.97 .0005 13.96 .0002
+ 14.92 .0001 15.92 .0001 19.93 .0001 22.92 .0001 23.96 .0001))
+
+ (vl-e4 '(1.00 .0649 2.00 .0412 3.01 .0315 4.00 .0446 5.01 .0414 6.01 .0209 7.02 .0189
+ 8.01 .0101 9.03 .0012 10.03 .0029 11.02 .0041 12.00 .0012 13.04 .0004 14.05 .0005 15.03 .0009
+ 16.06 .0005 17.09 .0004 18.07 .0006 19.08 .0004 20.10 .0001 21.09 .0001 22.09 .0004 23.11 .0002
+ 24.06 .0002 25.07 .0002 26.07 .0002 27.08 .0002 30.10 .0001))
+
+ (vl-f4 '(1.00 .0700 2.00 .0235 3.00 .0294 4.00 .0101 4.99 .0173 5.99 .0081 6.99 .0023
+ 7.99 .0006 8.97 .0101 9.98 .0060 11.00 .0063 11.99 .0038 13.00 .0011 13.98 .0003 15.01 .0009
+ 16.02 .0005 17.01 .0004 18.06 .0002 19.01 .0004 20.01 .0004 21.03 .0005 22.04 .0002 23.00 .0003
+ 24.00 .0001 25.99 .0001 29.04 .0001 31.04 .0001))
+
+ (vl-fs4 '(1.01 .1897 2.02 .0152 3.02 .0312 4.03 .0224 5.03 .0483 6.04 .0217 7.05 .0184
+ 8.07 .0051 9.06 .0031 10.08 .0047 11.09 .0040 12.10 .0021 13.10 .0006 14.11 .0010 15.14 .0012
+ 16.14 .0009 17.15 .0004 18.16 .0010 19.18 .0003 20.19 .0005 21.14 .0002 22.17 .0002 23.18 .0002
+ 24.18 .0002 26.22 .0001 29.25 .0002 30.26 .0002))
+
+ (vl-g4 '(1.01 .0788 2.01 .0144 2.99 .0064 3.99 .0078 5.02 .0053 6.00 .0045 7.01 .0011
+ 7.98 .0025 9.03 .0010 10.02 .0014 11.02 .0002 12.02 .0001 13.02 .0003 14.05 .0002 15.07 .0002
+ 17.05 .0001 18.02 .0002 19.07 .0001))
+
+ (vl-gs4 '(1.00 .2902 2.01 .0644 3.01 .0378 4.02 .0473 5.02 .0027 6.03 .0278 7.04 .0077
+ 8.04 .0105 9.04 .0026 10.04 .0106 11.05 .0011 12.05 .0014 13.06 .0045 14.09 .0015 15.09 .0010
+ 16.09 .0008 17.09 .0011 18.10 .0010 19.09 .0011 20.09 .0004 21.10 .0010 22.10 .0006 23.11 .0003
+ 24.10 .0002 24.14 .0002 25.15 .0002 26.14 .0005 27.14 .0003 30.13 .0002 31.14 .0001))
+
+ (vl-a4 '(1.00 .3420 2.02 .0045 3.00 .0160 4.00 .0105 5.01 .0370 6.02 .0193 7.01 .0342
+ 8.02 .0178 9.02 .0146 10.04 .0025 11.03 .0011 12.02 .0010 13.03 .0009 14.03 .0003 15.05 .0031
+ 16.04 .0009 17.04 .0004 18.04 .0004 19.03 .0004 20.06 .0005 21.05 .0001 22.04 .0001 24.06 .0001
+ 25.07 .0002 26.08 .0001))
+
+ (vl-as4 '(1.00 .1478 2.00 .0159 3.00 .0033 3.99 .0600 5.00 .0291 5.99 .0028 7.01 .0118
+ 8.00 .0115 8.99 .0039 9.99 .0020 10.99 .0024 11.99 .0012 12.99 .0009 14.01 .0011 15.00 .0015
+ 16.01 .0004 17.02 .0001 18.01 .0001 19.01 .0002 20.00 .0002 20.98 .0001 22.00 .0001 24.02 .0002
+ 25.00 .0002))
+
+ (vl-b4 '(1.00 .0247 2.01 .0570 3.01 .0115 4.02 .0167 5.02 .0162 6.02 .0154 7.02 .0056
+ 8.04 .0021 9.04 .0003 10.04 .0023 11.04 .0003 12.07 .0005 13.09 .0005 14.06 .0003 15.06 .0004
+ 16.09 .0003 17.07 .0002 18.10 .0003 19.10 .0002))
+
+ (vl-c5 '(1.00 .0690 1.99 .0372 2.99 .0326 3.99 .0222 4.99 .0107 5.97 .0033 6.99 .0029
+ 7.98 .0013 8.97 .0005 9.98 .0008 10.97 .0004 11.97 .0006 12.99 .0003 13.99 .0002 14.97 .0001
+ 16.95 .0001 16.98 .0001 17.97 .0001 19.96 .0001))
+
+ (vl-cs5 '(1.00 .1446 2.01 .0499 3.01 .0768 4.02 .0436 5.02 .0287 6.03 .0204 7.03 .0301
+ 7.11 .0011 8.04 .0010 9.04 .0036 10.05 .0030 11.05 .0023 12.06 .0008 13.06 .0005 14.07 .0009
+ 15.08 .0005 16.09 .0009 17.08 .0003 18.10 .0006 19.09 .0008 20.13 .0002 21.11 .0001 22.14 .0001
+ 23.11 .0002))
+
+ (vl-d5 '(1.00 .0614 1.99 .0194 2.99 .0196 3.99 .0159 5.00 .0057 6.00 .0031 7.01 .0024
+ 8.00 .0004 9.00 .0003 9.98 .0003 11.01 .0005 11.99 .0003 12.99 .0002 16.99 .0001 17.98 .0001))
+
+ (vl-ds5 '(.99 .1393 1.99 .0875 2.99 .1163 3.98 .0152 4.98 .0551 5.97 .0214 6.97 .0072
+ 7.96 .0017 8.95 .0028 9.96 .0034 10.95 .0015 11.94 .0010 12.95 .0009 13.91 .0008 14.94 .0011
+ 15.93 .0005 16.93 .0007 17.92 .0004 17.97 .0002 18.94 .0002 19.93 .0003 20.92 .0004 21.90 .0001))
+
+ (vl-e5 '(1.00 .1926 2.00 .0731 3.00 .0543 4.00 .0258 5.02 .0238 6.02 .0177 7.03 .0206
+ 8.03 .0081 9.03 .0030 10.05 .0043 11.03 .0011 12.06 .0007 13.08 .0013 14.10 .0007 15.11 .0004
+ 16.14 .0002))
+
+ (vl-f5 '(1.00 .0684 2.00 .0409 3.00 .0344 4.00 .0439 5.00 .0686 6.00 .0504 7.00 .0045
+ 8.00 .0056 9.00 .0094 10.00 .0028 11.00 .0015 11.99 .0010 13.00 .0032 14.00 .0017 15.00 .0010
+ 16.01 .0011 16.99 .0003 18.01 .0006 19.00 .0003))
+
+ (vl-fs5 '(1.00 .0291 2.01 .0323 3.01 .0110 4.02 .0071 5.04 .0028 6.04 .0010 7.08 .0007
+ 8.08 .0003 9.09 .0004 10.12 .0002 11.06 .0003))
+
+ (vl-g5 '(1.00 .0980 1.99 .0303 3.00 .0044 4.01 .0107 5.03 .0027 6.03 .0011 7.00 .0010
+ 8.02 .0011 8.06 .0004 9.04 .0003 10.04 .0001))
+
+ (vl-gs5 '(1.01 .1116 2.01 .0200 3.03 .0147 4.03 .0034 5.08 .0061 6.10 .0012 7.06 .0005
+ 8.14 .0005 9.14 .0004))
+
+ (vl-a5 '(1.00 .0211 2.01 .0180 3.01 .0158 4.02 .0057 5.03 .0013 6.03 .0006 7.02 .0001))
+
+ (vl-as5 '(1.00 .0442 2.01 .0922 3.01 .0102 4.00 .0031 5.03 .0053 6.01 .0004 7.04 .0018
+ 7.08 .0009 8.06 .0004 9.06 .0006 10.06 .0003 11.06 .0003 12.09 .0002 13.09 .0002))
+
+ (vl-b5 '(1.01 .0061 2.01 .0016 3.01 .0014 4.03 .0005 5.04 .0005 5.06 .0001))
+
+ (vl-c6 '(1.01 .0039 2.00 .0005 3.02 .0006 4.03 .0001))
+
+ (vl-cs6 '(1.00 .0754 2.00 .1620 3.00 .1551 4.00 .0277 5.00 .0466 6.00 .0408 7.00 .0025
+ 8.00 .0055 9.00 .0048 9.99 .0034 10.99 .0039 11.99 .0005))
+
+ (vl-d6 '(1.00 .0905 2.00 .0808 3.00 .0909 4.00 .0616 5.00 .0172 5.99 .0043 7.01 .0044
+ 8.00 .0036 9.00 .0043 10.01 .0015 11.03 .0014))
+
+ (vl-ds6 '(1.00 .1772 2.00 .1029 3.00 .0398 4.01 .0602 5.00 .0222 6.01 .0073 7.01 .0037
+ 8.01 .0044 9.01 .0019 10.01 .0028 11.01 .0006 11.03 .0001))
+
+ (vl-e6 '(1.00 .1865 2.00 .2083 2.99 .0822 3.99 .0298 4.99 .0227 6.00 .0023 6.98 .0049
+ 7.99 .0021 8.98 .0022 9.98 .0003 9.99 .0003))
+
+ (vl-f6 '(1.01 .0841 2.01 .0654 3.02 .1346 4.03 .0041 5.04 .0077 6.05 .0088 7.05 .0016
+ 8.06 .0017 9.06 .0012 9.08 .0003 9.10 .0002 9.11 .0001))
+
+ (vl-fs6 '(1.00 .1693 2.02 .0779 3.03 .0411 4.03 .0147 5.04 .0085 6.05 .0080 7.06 .0088
+ 8.06 .0032 9.06 .0010 9.08 .0007 9.10 .0004))
+
+ (vl-g6 '(1.01 .2123 2.02 .2854 3.03 .0552 4.04 .0246 5.05 .0058 6.06 .0022 7.07 .0017
+ 8.09 .0029 9.10 .0001))
+
+ (vl-gs6 '(1.02 .1270 2.03 .0961 3.05 .0347 4.06 .0032 5.08 .0083 6.09 .0050 7.11 .0020
+ 8.12 .0013 8.14 .0002))
+
+ (vl-a6 '(1.02 .3359 2.03 .1252 3.05 .0238 4.07 .0155 5.09 .0053 6.10 .0051 7.12 .0025
+ 7.18 .0001))
+
+ (vl-as6 '(1.01 .2037 2.03 .0456 3.05 .0029 4.06 .0053 5.07 .0041 6.09 .0043 7.11 .0026
+ 7.13 .0006 7.14 .0001))
+
+ (vl-b6 '(1.02 .4213 2.04 .1379 3.06 .0067 4.06 .0041 4.08 .0039 5.09 .0026 6.11 .0027
+ 7.13 .0002))
+
+ (vl-c7 '(1.01 .1299 2.02 .1571 3.03 .0461 4.04 .0033 5.05 .0057 6.06 .0015))
+
+ (vl-cs7 '(1.01 .1471 2.03 .0526 3.05 .0161 4.06 .0037 5.08 .0017 6.09 .0005))
+
+ (vl-d7 '(1.01 .0321 2.02 .0529 3.03 .0046 4.03 .0054 4.04 .0021 5.04 .0010))
+
+ (vl-ds7 '(1.00 .1220 2.00 .0667 2.99 .0319 4.00 .0020 4.99 .0052 5.03 .0002))
+
+ (vl-e7 '(1.01 .1110 2.02 .0588 3.03 .0143 4.04 .0068 5.05 .0011))
+
+ (vl-f7 '(1.01 .0798 2.02 .0111 3.03 .0125 4.03 .0036 4.50 .0002 5.04 .0001))
+
+ (vl-fs7 '(1.02 .1071 2.04 .0117 3.06 .0148 4.08 .0092 4.11 .0007 4.13 .0005 4.16 .0003
+ 4.23 .0002 4.24 .0002 4.28 .0002 4.34 .0001 4.39 .0001))
+
+ (vl-g7 '(1.02 .2741 2.05 .0256 3.07 .0122 4.11 .0002 4.14 .0001))
+
+ (vl-gs7 '(1.02 .1027 2.05 .0192 3.07 .0091))
+
+ (vl-a7 '(1.02 .0796 2.04 .0112 3.06 .0030))
+
+ (vl-as7 '(1.06 .1256))
+
+ (vl-b7 '(1.08 .1494 3.24 .0003))
+
+ (vl-c8 '(1.07 .0582 3.25 .0004))
+
+ (vl-cs8 '(1.08 .0889))
+
+ (vl-d8 '(1.07 .0573))
+
+
+
+ (almf-c3 '(1.01 .0037 2.01 .0482 3.01 .0275 4.01 .0182 5.03 .0047 6.03 .0032 7.03 .0005
+ 8.03 .0050 9.05 .0044 10.02 .0016 11.06 .0011 12.06 .0004 13.06 .0006 14.16 .0001 15.12 .0001
+ 16.12 .0004 17.12 .0004 19.08 .0003 20.11 .0004 23.11 .0002 24.14 .0003 25.14 .0003 27.12 .0002
+ 28.13 .0001 30.17 .0001))
+
+ (almf-cs3 '(1.01 .0043 2.01 .0357 3.02 .0452 4.01 .0156 5.02 .0152 6.04 .0022 7.04 .0039
+ 8.06 .0078 9.06 .0049 10.09 .0046 11.24 .0004 12.08 .0016 13.09 .0015 14.10 .0021 15.12 .0006
+ 16.12 .0012 17.12 .0002 18.16 .0004 19.16 .0006 20.15 .0006 21.15 .0007 22.16 .0005 23.17 .0005
+ 24.13 .0004 25.48 .0003 26.19 .0002 27.18 .0002 28.20 .0002 30.26 .0001 31.25 .0002 34.23 .0001))
+
+ (almf-d3 '(1.01 .0052 2.03 .0062 3.01 .0292 4.05 .0043 5.02 .0149 5.97 .0018 7.02 .0016
+ 8.05 .0029 9.04 .0005 10.06 .0012 11.04 .0006 12.12 .0002 13.05 .0005 14.10 .0004 15.08 .0004
+ 15.99 .0001 17.18 .0001 18.07 .0004 19.06 .0001 20.08 .0003 22.11 .0003 24.13 .0002 25.15 .0001
+ 26.12 .0001))
+
+ (almf-ds3 '(1.01 .0043 2.01 .0532 3.01 .0389 4.00 .0094 5.01 .0031 6.00 .0038 7.00 .0219
+ 8.00 .0122 8.99 .0129 10.00 .0014 11.00 .0021 12.01 .0037 13.01 .0021 14.01 .0017 15.02 .0015
+ 16.01 .0023 17.03 .0024 18.00 .0008 19.03 .0011 20.04 .0003 21.04 .0009 22.04 .0003 23.00 .0012
+ 24.00 .0011 25.01 .0007 27.02 .0002 28.02 .0004 29.03 .0003 30.04 .0002 31.04 .0001 46.55 .0001
+ 48.01 .0001))
+
+ (almf-e3 '(1.00 .0123 2.00 .0733 2.99 .0330 4.00 .0098 5.00 .0171 6.00 .0013 7.01 .0117
+ 7.99 .0020 9.00 .0044 10.01 .0012 11.01 .0014 12.00 .0021 13.02 .0002 14.02 .0016 15.03 .0012
+ 16.03 .0028 17.02 .0007 18.02 .0019 19.03 .0008 20.04 .0013 21.03 .0005 22.03 .0005 23.03 .0003
+ 24.04 .0003 26.03 .0005 27.04 .0001 28.06 .0001 29.04 .0002))
+
+ (almf-f3 '(1.00 .0185 2.00 .0813 3.00 .0142 3.99 .0132 5.00 .0066 5.99 .0027 6.93 .0009
+ 8.01 .0042 8.99 .0018 9.97 .0002 10.97 .0010 12.00 .0008 13.00 .0012 13.98 .0003 14.96 .0006
+ 16.00 .0004 17.01 .0005 18.00 .0003 18.98 .0005 19.99 .0002 20.99 .0002 22.00 .0002))
+
+ (almf-fs3 '(1.01 .0480 2.01 .0778 3.01 .0124 4.01 .0204 5.05 .0008 6.03 .0068 7.05 .0052
+ 8.06 .0017 9.07 .0017 10.05 .0008 11.07 .0010 12.08 .0008 13.11 .0002 14.08 .0006 15.10 .0002
+ 16.09 .0013 17.12 .0003 18.10 .0003 19.11 .0004 20.14 .0001 23.17 .0001))
+
+ (almf-g3 '(1.00 .0526 2.00 .0242 2.99 .0351 3.99 .0076 4.98 .0062 5.99 .0085 6.99 .0061
+ 8.04 .0006 8.98 .0005 10.01 .0006 10.97 .0003 11.96 .0004 13.07 .0004 13.95 .0003 14.99 .0003
+ 15.20 .0002 17.93 .0002 18.02 .0002 24.96 .0001))
+
+ (almf-gs3 '(.99 .0523 1.99 .0560 2.98 .0166 3.98 .0183 4.96 .0005 5.98 .0066 6.99 .0026
+ 7.96 .0011 8.95 .0013 9.95 .0026 10.95 .0019 11.96 .0017 12.94 .0005 13.92 .0002 14.94 .0006
+ 15.95 .0007 16.94 .0007 17.96 .0002 18.92 .0002 19.93 .0002 20.92 .0002 21.94 .0001))
+
+ (almf-a3 '(1.00 .1590 2.00 .0394 3.02 .0076 3.99 .0222 5.00 .0063 5.93 .0008 6.97 .0016
+ 7.95 .0002 8.94 .0002 9.94 .0003 10.05 .0002 10.15 .0001 12.00 .0005 12.12 .0002 12.95 .0001
+ 15.98 .0002))
+
+ (almf-as3 '(1.00 .2533 2.00 .0498 3.00 .0178 3.99 .0108 5.00 .0245 6.00 .0112 6.99 .0066
+ 8.00 .0010 8.98 .0074 9.99 .0042 10.99 .0025 12.00 .0015 13.01 .0006 14.00 .0012 15.00 .0004
+ 16.02 .0004 17.00 .0010 18.00 .0005 18.99 .0002 19.98 .0002))
+
+ (almf-b3 '(1.00 .1639 2.00 .0436 3.01 .0584 4.01 .0080 5.01 .0117 6.01 .0208 7.02 .0062
+ 8.02 .0035 9.03 .0037 10.03 .0022 11.04 .0023 12.04 .0048 13.04 .0022 14.04 .0005 15.04 .0007
+ 16.05 .0012 17.05 .0010 18.06 .0005 19.05 .0001 20.06 .0005 21.07 .0002 24.07 .0002 25.08 .0002
+ 27.08 .0002 28.10 .0001 33.12 .0001))
+
+ (almf-c4 '(1.00 .0931 2.00 .0251 3.00 .0077 4.00 .0129 5.00 .0115 6.00 .0055 7.00 .0041
+ 8.01 .0046 9.00 .0013 10.00 .0067 11.02 .0011 12.02 .0021 12.99 .0002 14.01 .0007 15.02 .0008
+ 16.03 .0007 17.02 .0004 19.02 .0003 20.05 .0001 24.04 .0001))
+
+ (almf-cs4 '(1.01 .0587 2.01 .0263 3.02 .0299 4.03 .0306 5.04 .0172 6.04 .0097 7.05 .0024
+ 8.06 .0034 9.06 .0053 10.07 .0065 11.08 .0025 12.09 .0005 13.10 .0016 14.11 .0011 15.11 .0009
+ 16.12 .0004 17.13 .0002 18.13 .0003 21.15 .0002 23.17 .0001 24.18 .0001 25.19 .0002 30.23 .0001
+ 32.25 .0001))
+
+ (almf-d4 '(1.00 .0619 2.00 .0432 3.01 .0479 4.01 .0136 5.00 .0220 6.01 .0064 7.02 .0138
+ 8.02 .0033 9.02 .0066 10.06 .0006 11.02 .0019 12.01 .0013 13.02 .0008 14.01 .0004 15.03 .0007
+ 16.04 .0003 17.03 .0001 18.02 .0001 21.04 .0003))
+
+ (almf-ds4 '(1.00 .0762 1.99 .0071 2.99 .0085 3.99 .0120 4.98 .0064 5.98 .0018 6.98 .0039
+ 7.99 .0027 8.96 .0017 9.95 .0007 10.98 .0006 11.95 .0003 12.98 .0006 13.98 .0007 15.97 .0002
+ 19.96 .0001))
+
+ (almf-e4 '(.99 .0726 1.99 .0195 2.99 .0147 3.98 .0106 4.99 .0069 6.00 .0026 6.99 .0046
+ 7.99 .0105 8.97 .0017 10.01 .0007 10.97 .0022 11.99 .0009 12.99 .0011 13.98 .0001 14.96 .0002
+ 15.96 .0001 16.99 .0001 17.95 .0002 18.98 .0002 20.98 .0001 21.97 .0001))
+
+ (almf-f4 '(1.00 .0772 2.00 .0150 3.00 .0166 4.01 .0118 4.99 .0024 6.01 .0067 7.03 .0017
+ 8.00 .0012 9.02 .0017 10.02 .0011 11.03 .0008 12.04 .0004 13.04 .0007 14.03 .0002 15.04 .0002
+ 16.04 .0001))
+
+ (almf-fs4 '(.99 .1309 1.99 .0550 2.98 .0321 3.98 .0270 4.97 .0070 5.97 .0099 6.96 .0041
+ 7.96 .0033 8.95 .0023 9.94 .0017 10.94 .0023 11.93 .0015 12.93 .0006 13.95 .0002 14.93 .0002
+ 15.91 .0002 16.91 .0003 17.92 .0001 18.90 .0003 19.93 .0001 22.87 .0001 23.88 .0001))
+
+ (almf-g4 '(.99 .0515 2.00 .0153 3.00 .0281 4.00 .0071 5.01 .0020 6.00 .0045 7.02 .0006
+ 8.00 .0054 8.99 .0020 10.00 .0031 11.01 .0023 12.02 .0003 13.00 .0004 14.01 .0002 15.02 .0003
+ 15.98 .0002 16.02 .0002 18.03 .0002 19.01 .0001))
+
+ (almf-gs4 '(1.00 .0592 2.00 .0287 3.00 .0196 3.99 .0175 4.99 .0168 6.00 .0071 6.07 .0008
+ 7.00 .0003 7.99 .0019 8.98 .0007 9.98 .0012 10.99 .0012 11.98 .0004 12.98 .0003 13.99 .0002
+ 14.96 .0001 15.98 .0001 16.97 .0002 17.96 .0002))
+
+ (almf-a4 '(1.01 .0784 2.01 .0480 3.02 .0131 4.02 .0074 5.03 .0141 6.03 .0173 7.04 .0070
+ 8.04 .0033 9.06 .0154 9.12 .0016 10.07 .0011 11.07 .0013 12.07 .0009 13.09 .0008 14.07 .0006
+ 15.09 .0002 16.10 .0005 17.10 .0003 19.12 .0001 23.14 .0001))
+
+ (almf-as4 '(1.00 .0507 2.00 .0304 3.00 .0303 4.00 .0084 5.00 .0072 6.00 .0098 6.99 .0058
+ 8.01 .0036 9.01 .0023 10.00 .0010 11.00 .0008 12.00 .0007 12.97 .0005 13.02 .0004 14.00 .0003
+ 14.99 .0003 16.01 .0001 17.01 .0002 18.00 .0001 20.01 .0001))
+
+ (almf-b4 '(1.00 .0340 2.00 .0113 3.01 .0098 4.02 .0033 5.03 .0013 6.05 .0008 7.02 .0007
+ 8.07 .0006 9.01 .0001))
+
+ (almf-c5 '(1.00 .0384 2.00 .0426 3.01 .0092 4.02 .0239 5.02 .0184 6.02 .0031 7.03 .0029
+ 8.04 .0016 8.10 .0006 9.04 .0005 10.04 .0003 11.05 .0006 12.05 .0007 13.06 .0002 15.07 .0002))
+
+ (almf-cs5 '(1.00 .0159 2.00 .0592 3.00 .0390 4.00 .0272 5.00 .0121 6.00 .0032 7.01 .0124
+ 8.01 .0055 9.00 .0009 10.01 .0016 11.01 .0007 12.01 .0006 13.02 .0020 14.02 .0010 15.02 .0007
+ 16.03 .0004 17.03 .0002 18.02 .0001 19.03 .0001 20.03 .0003 21.03 .0002 22.03 .0003 23.03 .0002))
+
+ (almf-d5 '(1.01 .0376 2.01 .0409 3.02 .0136 4.03 .0016 5.05 .0080 6.05 .0044 7.06 .0036
+ 8.07 .0018 9.07 .0007 10.08 .0011 11.09 .0002 12.09 .0004 13.12 .0003 14.11 .0001 16.15 .0002
+ 17.16 .0001 20.18 .0001))
+
+ (almf-ds5 '(1.00 .0391 2.01 .0445 3.01 .0188 4.02 .0329 5.02 .0185 6.02 .0311 7.03 .0107
+ 8.03 .0032 9.03 .0010 10.03 .0009 11.04 .0019 12.04 .0019 13.05 .0005 14.06 .0004 15.05 .0007
+ 16.06 .0002 17.07 .0002 18.08 .0002 19.07 .0005 20.07 .0003 21.08 .0001))
+
+ (almf-e5 '(1.00 .0869 2.00 .0181 3.01 .0252 4.01 .0520 5.01 .0040 6.02 .0336 7.02 .0108
+ 8.03 .0070 9.03 .0023 10.03 .0009 11.03 .0017 12.02 .0004 13.04 .0012 14.04 .0006 15.05 .0016
+ 16.06 .0007 17.06 .0003 18.06 .0012 19.07 .0001 20.06 .0001))
+
+ (almf-f5 '(1.01 .0905 2.02 .0649 3.02 .0406 4.03 .0295 5.04 .0038 6.05 .0088 7.06 .0009
+ 8.07 .0021 9.07 .0037 10.09 .0022 11.09 .0014 12.09 .0018 13.11 .0006 14.12 .0009 15.13 .0004
+ 16.12 .0003 17.14 .0006 18.15 .0002))
+
+ (almf-fs5 '(.99 .0868 1.98 .0447 2.98 .0303 3.97 .0092 4.96 .0183 5.95 .0121 6.94 .0033
+ 7.95 .0010 8.92 .0022 9.92 .0007 10.91 .0007 11.90 .0007 12.89 .0014 13.87 .0004 14.88 .0006
+ 14.91 .0003 15.87 .0002 16.85 .0003))
+
+ (almf-g5 '(1.00 .0467 2.00 .0739 3.00 .0255 4.00 .0277 5.00 .0349 6.00 .0119 7.00 .0024
+ 8.00 .0085 9.00 .0016 9.99 .0012 11.00 .0004 11.99 .0014 12.99 .0024 13.99 .0017 14.99 .0007
+ 15.99 .0004 16.98 .0001))
+
+ (almf-gs5 '(.99 .0605 1.99 .0384 2.98 .0154 3.98 .0036 4.97 .0164 5.96 .0039 6.96 .0036
+ 7.95 .0040 8.94 .0012 9.94 .0006 10.93 .0015 11.93 .0012 12.93 .0008 13.91 .0010 14.90 .0005
+ 15.91 .0001))
+
+ (almf-a5 '(1.00 .1051 2.01 .0322 3.02 .0393 4.03 .0112 5.03 .0099 6.04 .0074 7.05 .0054
+ 8.05 .0030 9.06 .0019 10.07 .0006 11.07 .0023 12.08 .0004 13.08 .0005 14.09 .0006 14.11 .0001
+ 15.11 .0001))
+
+ (almf-as5 '(1.00 .0284 2.01 .0161 3.02 .0248 4.03 .0414 5.03 .0135 6.04 .0028 7.05 .0021
+ 8.06 .0006 9.07 .0009 10.07 .0010 11.08 .0012 12.10 .0003 13.09 .0010 14.10 .0003))
+
+ (almf-b5 '(.99 .0354 1.98 .0173 2.97 .0086 3.96 .0204 3.99 .0077 4.03 .0067 4.06 .0037
+ 4.95 .0034 5.93 .0030 5.96 .0015 5.98 .0009 6.92 .0007 7.92 .0008 8.91 .0017 9.90 .0008
+ 9.93 .0006 10.88 .0003 11.91 .0003 12.86 .0004 12.90 .0002))
+
+ (almf-c6 '(1.01 .0675 2.01 .0578 3.02 .0346 4.03 .0170 5.03 .0082 6.04 .0050 7.06 .0032
+ 8.03 .0009 9.06 .0009 10.07 .0008 11.09 .0010 12.03 .0002))
+
+ (almf-cs6 '(1.00 .0896 1.99 .0634 3.01 .0037 3.98 .0105 4.98 .0030 5.98 .0019 6.97 .0020
+ 7.97 .0014 8.00 .0007 8.99 .0005 9.96 .0005 10.95 .0008 10.98 .0005 11.00 .0003 11.02 .0003
+ 11.03 .0002 11.06 .0002 11.95 .0001 11.98 .0001))
+
+ (almf-d6 '(1.00 .0593 2.00 .0364 3.01 .0142 4.01 .0065 5.02 .0063 6.01 .0024 7.02 .0010
+ 8.02 .0019 9.02 .0015 10.03 .0007 11.02 .0002))
+
+ (almf-ds6 '(1.00 .0410 1.99 .0353 2.99 .0291 3.99 .0089 4.99 .0066 5.98 .0023 6.99 .0012
+ 7.96 .0011 7.99 .0006 8.94 .0004 8.98 .0003 9.95 .0001))
+
+ (almf-e6 '(1.01 .0254 2.01 .0252 3.02 .0365 4.03 .0034 5.02 .0013 6.02 .0010 7.08 .0006
+ 8.02 .0010 9.03 .0007 9.12 .0004))
+
+ (almf-f6 '(1.00 .1896 2.00 .0411 3.00 .0216 4.00 .0019 5.00 .0032 6.01 .0012 7.02 .0007
+ 7.99 .0026 9.00 .0003 9.03 .0002))
+
+ (almf-fs6 '(1.01 .0285 2.01 .0189 3.02 .0213 4.02 .0033 5.03 .0024 6.03 .0010 7.04 .0016
+ 8.05 .0015 9.05 .0003 9.06 .0002))
+
+ (almf-g6 '(1.00 .1939 2.00 .0339 3.00 .0219 4.01 .0079 5.01 .0025 6.01 .0017 7.01 .0014
+ 7.95 .0009 8.00 .0006 8.02 .0003))
+
+ (almf-gs6 '(1.00 .1069 2.00 .0146 3.00 .0220 4.00 .0046 5.00 .0020 6.00 .0027 6.99 .0011
+ 8.00 .0003))
+
+ (almf-a6 '(1.00 .0952 1.99 .0201 3.00 .0015 3.99 .0064 4.98 .0021 5.97 .0009 6.98 .0010))
+
+ (almf-as6 '(1.00 .0132 1.99 .0635 2.99 .0057 3.98 .0054 3.99 .0034 4.99 .0011 5.96 .0012
+ 5.98 .0008 5.99 .0007 6.96 .0004 6.98 .0004))
+
+ (almf-b6 '(1.00 .0241 2.01 .0417 3.02 .0098 3.99 .0016 4.02 .0016 5.03 .0016 6.04 .0012)))
+
+ (curlet)))
+
\ No newline at end of file
diff --git a/spokenword.scm b/spokenword.scm
index 53b0fc9..ef627d9 100644
--- a/spokenword.scm
+++ b/spokenword.scm
@@ -24,8 +24,7 @@
(define secs->samples
(lambda (time)
- (define sr 44100)
- (round (* sr time))))
+ (round (* 44100 time))))
(define size (secs->samples 0.10)) ;length of the window for rms and peak calculations
(define some-size (secs->samples 0.05)) ;length of the cursor step for right/left movement
@@ -87,10 +86,10 @@
(lambda (position)
(let ((in-mark (find-mark "In"))
(out-mark (find-mark "Out")))
- (if (and in-mark
+ (if (and (mark? in-mark)
(<= (mark-sample in-mark) position))
(delete-mark in-mark))
- (if out-mark
+ (if (mark? out-mark)
(set! (mark-sample out-mark) position)
(add-mark position 0 0 "Out")))))
@@ -98,10 +97,10 @@
(lambda (position)
(let ((in-mark (find-mark "In"))
(out-mark (find-mark "Out")))
- (if (and out-mark
+ (if (and (mark? out-mark)
(>= (mark-sample out-mark) position))
(delete-mark out-mark))
- (if in-mark
+ (if (mark? in-mark)
(set! (mark-sample in-mark) position)
(add-mark position 0 0 "In")))))
@@ -109,8 +108,8 @@
(lambda ()
(let ((in-mark (find-mark "In"))
(out-mark (find-mark "Out")))
- (if (and in-mark
- out-mark
+ (if (and (mark? in-mark)
+ (mark? out-mark)
(< (mark-sample out-mark) (mark-sample in-mark)))
(begin
(set! (cursor) (mark-sample out-mark))
@@ -128,8 +127,8 @@
(if (= reason 0)
(play (selected-sound) in-position (+ in-position preview-length))))
(if (and
- in-mark
- out-mark)
+ (mark? in-mark)
+ (mark? out-mark))
(if (< out-position in-position)
(play (max 0 (- out-position preview-length)) #f #f #f out-position #f play-next))
(play (selected-sound) (cursor) (+ (cursor) preview-length)))))
diff --git a/stochastic.scm b/stochastic.scm
index 9c06794..6c195c4 100644
--- a/stochastic.scm
+++ b/stochastic.scm
@@ -68,19 +68,18 @@
(cos (random 6.283185307179586))))))
(set! (xy-array (modulo m xy-array-l))
;;mirror stuff for x
- (cond ((or (< (round xmax) (+ dx xdev))
- (> (round xmin)(+ dx xdev)))
- (max (min ;;this mirror is attentuated
- (round (+ (* xfb prev-dx) (* (- 1 xfb) (- dx xdev))))
- (round xmax))
- (round xmin)))
- (else (round (+ (* xfb prev-dx)
- (* (- 1 xfb) (+ dx xdev)))))))
+ (if (>= (round xmax) (+ dx xdev) (round xmin))
+ (round (+ (* xfb prev-dx)
+ (* (- 1 xfb) (+ dx xdev))))
+ (max (min (round (+ (* xfb prev-dx)
+ (* (- 1 xfb) (- dx xdev))))
+ (round xmax))
+ (round xmin))))
(set! (xy-array (+ (modulo m xy-array-l) 1))
;;mirror stuff for y
- (cond ((or (< b (+ y ydev)) (> (- b) (+ y ydev)))
- (max (min (- y ydev) b) (- b)))
- (else (+ y ydev))))
+ (if (>= b (+ y ydev) (- b))
+ (+ y ydev)
+ (max (min (- y ydev) b) (- b))))
(set! m (+ m 2))
(set! dt 0))
(set! dt (+ dt 1))
diff --git a/strad.scm b/strad.scm
index a3a3538..9af47c0 100644
--- a/strad.scm
+++ b/strad.scm
@@ -154,23 +154,27 @@
(do ((i beg (+ i 1)))
((= i end))
- (set! vib (- (/ (+ (* (vinbridge indexl_2) (- alphal 1) (- alphal 2))
- (* (vinbridge indexl) alphal (- alphal 1)))
+ (set! vib (- (/ (* (- alphal 1)
+ (+ (* (vinbridge indexl_2) (- alphal 2))
+ (* (vinbridge indexl) alphal)))
2)
(* (vinbridge indexl_1) alphal (- alphal 2))))
- (set! vin (- (/ (+ (* (vinut indexr_2) (- alphar 1) (- alphar 2))
- (* (vinut indexr) (- alphar 1) alphar))
+ (set! vin (- (/ (* (- alphar 1)
+ (+ (* (vinut indexr_2) (- alphar 2))
+ (* (vinut indexr) alphar)))
2)
(* (vinut indexr_1) alphar (- alphar 2))))
- (set! vibt (- (/ (+ (* (vinbridget indexlt_2) (- alphalt 1) (- alphalt 2))
- (* (vinbridget indexlt) alphalt (- alphalt 1)))
+ (set! vibt (- (/ (* (- alphalt 1)
+ (+ (* (vinbridget indexlt_2) (- alphalt 2))
+ (* (vinbridget indexlt) alphalt)))
2)
(* (vinbridget indexlt_1) alphalt (- alphalt 2))))
- (set! vint (- (/ (+ (* (vinutt indexrt_2) (- alphart 1) (- alphart 2))
- (* (vinutt indexrt) (- alphart 1) alphart))
+ (set! vint (- (/ (* (- alphart 1)
+ (+ (* (vinutt indexrt_2) (- alphart 2))
+ (* (vinutt indexrt) alphart)))
2)
(* (vinutt indexrt_1) alphart (- alphart 2))))
diff --git a/stuff.scm b/stuff.scm
index 04e5e67..c674e90 100644
--- a/stuff.scm
+++ b/stuff.scm
@@ -296,6 +296,15 @@
(flatten (cdr lst1) (cdr lst2) args)))))
, at body))
+#|
+;; kinda ugly!
+(define-macro (and-map func args)
+ `(let and-map-loop ((args ,args))
+ (or (null? args)
+ (and (eval (list ,func (car args)))
+ (and-map-loop (cdr args))))))
+|#
+
(define-macro (and-let* vars . body) ; bind vars, if any is #f stop, else evaluate body with those bindings
`(let () (and ,@(map (lambda (v) `(define , at v)) vars) (begin , at body))))
@@ -1397,7 +1406,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(v (unique-reactive-let-name)))
(define (rlet-symbol sym)
- (string->symbol (string-append "{" (symbol->string sym) "}-rlet")))
+ (symbol "{" (symbol->string sym) "}-rlet"))
(for-each
(lambda (bd)
@@ -1633,7 +1642,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
(make-shared-vector obj (list new-len) start))
((string? obj)
- (if end
+ (if (integer? end)
(substring obj start end)
(substring obj start)))
diff --git a/tools/gtk-header-diffs b/tools/gtk-header-diffs
index b7142f2..2869054 100755
--- a/tools/gtk-header-diffs
+++ b/tools/gtk-header-diffs
@@ -1,7 +1,7 @@
#!/bin/csh -f
-set gtkolddir = /home/bil/test/gtk+-3.20.3
-set gtknewdir = /home/bil/test/gtk+-3.21.1
+set gtkolddir = /home/bil/test/gtk+-3.21.1
+set gtknewdir = /home/bil/test/gtk+-3.21.2
set pangoolddir = /home/bil/test/pango-1.36.8
set pangonewdir = /home/bil/test/pango-1.36.8
set glibolddir = /home/bil/test/glib-2.39.3
diff --git a/tools/make-index.scm b/tools/make-index.scm
index 3d825f7..ccaaa78 100644
--- a/tools/make-index.scm
+++ b/tools/make-index.scm
@@ -12,18 +12,18 @@
(for-each
(lambda (name)
(set! (h name) #t))
- (list "after-graph-hook" "lisp-graph-hook" "before-transform-hook" "mix-release-hook" "stop-playing-channel-hook" "save-hook" "mus-error-hook"
- "mouse-enter-graph-hook" "mouse-leave-graph-hook" "open-raw-sound-hook" "select-channel-hook" "after-open-hook" "close-hook" "drop-hook" "update-hook"
- "just-sounds-hook" "mark-click-hook" "mark-drag-hook" "name-click-hook" "open-hook" "help-hook"
- "output-comment-hook" "play-hook" "snd-error-hook" "snd-warning-hook" "start-playing-hook" "stop-playing-hook"
- "stop-playing-region-hook" "mouse-enter-listener-hook" "mouse-leave-listener-hook" "window-property-changed-hook" "select-sound-hook"
- "print-hook" "exit-hook" "during-open-hook" "transform-hook" "mouse-enter-label-hook" "mouse-leave-label-hook" "initial-graph-hook"
- "graph-hook" "key-press-hook" "mouse-drag-hook" "mouse-press-hook" "enved-hook" "read-hook" "mouse-click-hook" "new-widget-hook"
- "mark-hook" "previous-files-select-hook" "dac-hook" "stop-dac-hook" "stop-playing-selection-hook" "after-apply-controls-hook"
- "draw-mark-hook" "bad-header-hook" "save-state-hook" "new-sound-hook" "color-hook" "orientation-hook" "listener-click-hook"
- "mix-click-hook" "after-save-state-hook" "mouse-enter-text-hook" "mouse-leave-text-hook" "mix-drag-hook"
- "start-playing-selection-hook" "selection-changed-hook" "*current-sound*"
- "before-save-state-hook" "after-save-as-hook" "after-transform-hook" "before-save-as-hook"))
+ '("after-graph-hook" "lisp-graph-hook" "before-transform-hook" "mix-release-hook" "stop-playing-channel-hook" "save-hook" "mus-error-hook"
+ "mouse-enter-graph-hook" "mouse-leave-graph-hook" "open-raw-sound-hook" "select-channel-hook" "after-open-hook" "close-hook" "drop-hook" "update-hook"
+ "just-sounds-hook" "mark-click-hook" "mark-drag-hook" "name-click-hook" "open-hook" "help-hook"
+ "output-comment-hook" "play-hook" "snd-error-hook" "snd-warning-hook" "start-playing-hook" "stop-playing-hook"
+ "stop-playing-region-hook" "mouse-enter-listener-hook" "mouse-leave-listener-hook" "window-property-changed-hook" "select-sound-hook"
+ "print-hook" "exit-hook" "during-open-hook" "transform-hook" "mouse-enter-label-hook" "mouse-leave-label-hook" "initial-graph-hook"
+ "graph-hook" "key-press-hook" "mouse-drag-hook" "mouse-press-hook" "enved-hook" "read-hook" "mouse-click-hook" "new-widget-hook"
+ "mark-hook" "previous-files-select-hook" "dac-hook" "stop-dac-hook" "stop-playing-selection-hook" "after-apply-controls-hook"
+ "draw-mark-hook" "bad-header-hook" "save-state-hook" "new-sound-hook" "color-hook" "orientation-hook" "listener-click-hook"
+ "mix-click-hook" "after-save-state-hook" "mouse-enter-text-hook" "mouse-leave-text-hook" "mix-drag-hook"
+ "start-playing-selection-hook" "selection-changed-hook" "*current-sound*"
+ "before-save-state-hook" "after-save-as-hook" "after-transform-hook" "before-save-as-hook"))
h))
(define scheme-constant-names
@@ -31,30 +31,29 @@
(for-each
(lambda (name)
(set! (h name) #t))
- (list "mus-out-format" "mus-unsupported" "mus-next" "mus-aifc" "mus-riff" "mus-rf64" "mus-nist" "mus-raw" "mus-ircam" "mus-aiff" "mus-bicsf"
- "mus-voc" "mus-svx" "mus-soundfont" "mus-unknown" "mus-bshort" "mus-lshort" "mus-mulaw" "mus-alaw" "mus-byte" "mus-ubyte"
- "mus-bfloat" "mus-lfloat" "mus-bint" "mus-lint" "mus-bintn" "mus-lintn" "mus-b24int" "mus-l24int" "mus-bdouble" "mus-ldouble"
- "mus-ubshort" "mus-ulshort" "mus-bdouble-unscaled" "mus-ldouble-unscaled" "mus-bfloat-unscaled" "mus-lfloat-unscaled"
- "mus-audio-default"
- "rectangular-window" "hann-window" "welch-window"
- "parzen-window" "bartlett-window" "hamming-window" "blackman2-window" "blackman3-window" "blackman4-window" "exponential-window"
- "riemann-window" "kaiser-window" "cauchy-window" "poisson-window" "gaussian-window" "tukey-window" "dolph-chebyshev-window"
- "samaraki-window" "ultraspherical-window" "blackman5-window" "blackman6-window" "blackman7-window" "blackman8-window"
- "blackman9-window" "blackman10-window" "rv2-window" "rv3-window" "rv4-window"
- "zoom-focus-left" "zoom-focus-right" "zoom-focus-active" "zoom-focus-middle" "graph-once"
- "graph-as-wavogram" "graph-as-sonogram" "graph-as-spectrogram" "cursor-cross" "cursor-line" "graph-lines" "graph-dots"
- "graph-filled" "graph-dots-and-lines" "graph-lollipops" "x-axis-in-seconds" "x-axis-in-samples" "x-axis-in-beats" "x-axis-in-measures"
- "x-axis-as-percentage" "show-all-axes" "show-all-axes-unlabelled" "show-no-axes" "show-x-axis" "show-x-axis-unlabelled"
- "cursor-in-view" "cursor-on-left" "cursor-on-right" "cursor-in-middle" "keyboard-no-action" "fourier-transform"
- "wavelet-transform" "haar-transform" "cepstrum" "hadamard-transform" "walsh-transform" "autocorrelation" "dont-normalize"
- "normalize-by-channel" "normalize-by-sound" "normalize-globally" "current-edit-position" "channels-separate"
- "channels-combined" "channels-superimposed" "speed-control-as-float" "speed-control-as-ratio" "speed-control-as-semitone"
- "enved-amplitude" "enved-spectrum" "enved-srate" "envelope-linear" "envelope-exponential" "enved-add-point"
- "enved-delete-point" "enved-move-point" "time-graph" "transform-graph" "lisp-graph" "copy-context" "cursor-context"
- "selection-context" "mark-context" "mus-interp-all-pass" "mus-interp-bezier" "mus-interp-hermite" "mus-interp-lagrange"
- "mus-interp-linear" "mus-interp-none" "mus-interp-sinusoidal"
- "sync-none" "sync-all" "sync-by-sound"
- ))
+ '("mus-out-format" "mus-unsupported" "mus-next" "mus-aifc" "mus-riff" "mus-rf64" "mus-nist" "mus-raw" "mus-ircam" "mus-aiff" "mus-bicsf"
+ "mus-voc" "mus-svx" "mus-soundfont" "mus-unknown" "mus-bshort" "mus-lshort" "mus-mulaw" "mus-alaw" "mus-byte" "mus-ubyte"
+ "mus-bfloat" "mus-lfloat" "mus-bint" "mus-lint" "mus-bintn" "mus-lintn" "mus-b24int" "mus-l24int" "mus-bdouble" "mus-ldouble"
+ "mus-ubshort" "mus-ulshort" "mus-bdouble-unscaled" "mus-ldouble-unscaled" "mus-bfloat-unscaled" "mus-lfloat-unscaled"
+ "mus-audio-default"
+ "rectangular-window" "hann-window" "welch-window"
+ "parzen-window" "bartlett-window" "hamming-window" "blackman2-window" "blackman3-window" "blackman4-window" "exponential-window"
+ "riemann-window" "kaiser-window" "cauchy-window" "poisson-window" "gaussian-window" "tukey-window" "dolph-chebyshev-window"
+ "samaraki-window" "ultraspherical-window" "blackman5-window" "blackman6-window" "blackman7-window" "blackman8-window"
+ "blackman9-window" "blackman10-window" "rv2-window" "rv3-window" "rv4-window"
+ "zoom-focus-left" "zoom-focus-right" "zoom-focus-active" "zoom-focus-middle" "graph-once"
+ "graph-as-wavogram" "graph-as-sonogram" "graph-as-spectrogram" "cursor-cross" "cursor-line" "graph-lines" "graph-dots"
+ "graph-filled" "graph-dots-and-lines" "graph-lollipops" "x-axis-in-seconds" "x-axis-in-samples" "x-axis-in-beats" "x-axis-in-measures"
+ "x-axis-as-percentage" "show-all-axes" "show-all-axes-unlabelled" "show-no-axes" "show-x-axis" "show-x-axis-unlabelled"
+ "cursor-in-view" "cursor-on-left" "cursor-on-right" "cursor-in-middle" "keyboard-no-action" "fourier-transform"
+ "wavelet-transform" "haar-transform" "cepstrum" "hadamard-transform" "walsh-transform" "autocorrelation" "dont-normalize"
+ "normalize-by-channel" "normalize-by-sound" "normalize-globally" "current-edit-position" "channels-separate"
+ "channels-combined" "channels-superimposed" "speed-control-as-float" "speed-control-as-ratio" "speed-control-as-semitone"
+ "enved-amplitude" "enved-spectrum" "enved-srate" "envelope-linear" "envelope-exponential" "enved-add-point"
+ "enved-delete-point" "enved-move-point" "time-graph" "transform-graph" "lisp-graph" "copy-context" "cursor-context"
+ "selection-context" "mark-context" "mus-interp-all-pass" "mus-interp-bezier" "mus-interp-hermite" "mus-interp-lagrange"
+ "mus-interp-linear" "mus-interp-none" "mus-interp-sinusoidal"
+ "sync-none" "sync-all" "sync-by-sound"))
h))
@@ -130,7 +129,7 @@
(string<? a (if (char=? (string-ref b 0) #\*) (substring b 1) b))))))
-(define (clean-and-downcase-first-char str caps topic file)
+(define (clean-and-downcase-first-char str caps file)
(if (char=? (str 0) #\|)
;; this is a main-index entry
(let* ((colonpos (or (char-position #\: str)
@@ -186,13 +185,12 @@
(substring line (+ hpos 4) hspos)
(substring line (+ hspos 5))))))))
- (if (not (let ((ln line))
- (and caps ; caps is the list of names with upper case chars from the make-index-1 invocation ("AIFF" for example)
- (do ((cap caps (cdr cap)))
- ((or (null? cap)
- (string-position (car cap) ln))
- (pair? cap))))))
- ;; find the first character of the >name< business and downcase it
+ (if (not (and caps ; caps is the list of names with upper case chars from the make-index-1 invocation ("AIFF" for example)
+ (do ((cap caps (cdr cap)))
+ ((or (null? cap)
+ (string-position (car cap) line))
+ (pair? cap)))))
+ ;; find the first character of the >name< business and downcase it
(let ((bpos (char-position #\> line)))
(set! (line (+ bpos 1)) (char-downcase (line (+ bpos 1))))))
@@ -205,14 +203,15 @@
(define (create-general str file)
- (let ((mid (char-position #\: str)))
- (make-ind :name (string-append "<a href=\""
- (or file "")
- "#"
- (substring str 0 mid)
- "\"><b>"
- (substring str (+ mid 1))
- "</b></a>")
+ (let* ((mid (char-position #\: str))
+ (name (string-append "<a href=\""
+ (or file "")
+ "#"
+ (substring str 0 mid)
+ "\"><b>"
+ (substring str (+ mid 1))
+ "</b></a>")))
+ (make-ind :name name
:sortby (string-downcase (substring str (+ mid 1))))))
@@ -281,14 +280,15 @@
len))
(href-normal-start (or (string-position "<a href=" xref loc)
(string-position "<A HREF=" xref loc)))
- (href-quiet-start (string-position "<a class=quiet href=" xref loc))
- (href-def-start (string-position "<a class=def href=" xref loc))
- (href-start (or href-normal-start href-quiet-start href-def-start))
+ (href-start (or href-normal-start
+ (string-position "<a class=quiet href=" xref loc)
+ (string-position "<a class=def href=" xref loc)))
(href-len (if href-normal-start 8 20))
- (href-end (and href-start
+ (href-end (and (integer? href-start)
(< href-start leof)
(char-position #\> xref (+ href-start 1))))
- (href (and href-start href-end (substring xref (+ href-start href-len) href-end))))
+ (href (and (integer? href-end)
+ (substring xref (+ href-start href-len) href-end))))
(set! url-str (string-append url-str
(if href
(if (char=? (href 1) #\#)
@@ -510,321 +510,320 @@
(let ((cur-names (hash-table-ref names file)))
(hash-table-set! names file (if cur-names (cons symbol cur-names) (list symbol))))))
- (list
- (list '*libm* "libm.scm")
- (list '*libgdbm* "libgdbm.scm")
- (list '*libdl* "libdl.scm")
- (list '*libc* "libc.scm")
- (list '*libgsl* "libgsl.scm")
- (list '*repl* "repl.scm")
- (list '*rgb* "rgb.scm")
- (list '*spectr* "spectr.scm")
-
- (list 'with-sound "ws.scm")
- (list 'with-mixed-sound "ws.scm")
- (list 'with-full-sound "ws.scm")
- (list 'with-temp-sound "ws.scm")
- (list 'with-marked-sound "ws.scm")
- (list 'with-simple-sound "ws.scm")
- (list 'sound-let "ws.scm")
- (list 'definstrument "ws.scm")
- (list 'defgenerator "generators.scm")
+ '((*libm* "libm.scm")
+ (*libgdbm* "libgdbm.scm")
+ (*libdl* "libdl.scm")
+ (*libc* "libc.scm")
+ (*libgsl* "libgsl.scm")
+ (*repl* "repl.scm")
+ (*rgb* "rgb.scm")
+ (*spectr* "spectr.scm")
+ (*lint* "lint.scm")
+
+ (with-sound "ws.scm")
+ (with-mixed-sound "ws.scm")
+ (with-full-sound "ws.scm")
+ (with-temp-sound "ws.scm")
+ (with-marked-sound "ws.scm")
+ (with-simple-sound "ws.scm")
+ (sound-let "ws.scm")
+ (definstrument "ws.scm")
+ (defgenerator "generators.scm")
- (list 'channel-sync "extensions.scm")
- (list 'xe-envelope "xm-enved.scm")
- (list '*clm-srate* "ws.scm")
- (list '*clm-file-name* "ws.scm")
- (list '*clm-channels* "ws.scm")
- (list '*clm-sample-type* "ws.scm")
- (list '*clm-header-type* "ws.scm")
- (list '*clm-verbose* "ws.scm")
- (list '*clm-play* "ws.scm")
- (list '*clm-statistics* "ws.scm")
- (list '*clm-reverb* "ws.scm")
- (list '*clm-reverb-channels* "ws.scm")
- (list '*clm-reverb-data* "ws.scm")
- (list '*clm-table-size* "ws.scm")
- (list '*clm-file-buffer-size* "ws.scm")
- (list '*clm-locsig-type* "ws.scm")
- (list '*clm-clipped* "ws.scm")
- (list '*clm-array-print-length* "ws.scm")
- (list '*clm-player* "ws.scm")
- (list '*clm-notehook* "ws.scm")
- (list '*clm-with-sound-depth* "ws.scm")
- (list '*clm-default-frequency* "ws.scm")
- (list '*clm-delete-reverb* "ws.scm")
- (list '*to-snd* "ws.scm")
- (list '*clm-search-list* "ws.scm")
- (list '*definstrument-hook* "ws.scm")
+ (channel-sync "extensions.scm")
+ (xe-envelope "xm-enved.scm")
+ (*clm-srate* "ws.scm")
+ (*clm-file-name* "ws.scm")
+ (*clm-channels* "ws.scm")
+ (*clm-sample-type* "ws.scm")
+ (*clm-header-type* "ws.scm")
+ (*clm-verbose* "ws.scm")
+ (*clm-play* "ws.scm")
+ (*clm-statistics* "ws.scm")
+ (*clm-reverb* "ws.scm")
+ (*clm-reverb-channels* "ws.scm")
+ (*clm-reverb-data* "ws.scm")
+ (*clm-table-size* "ws.scm")
+ (*clm-file-buffer-size* "ws.scm")
+ (*clm-locsig-type* "ws.scm")
+ (*clm-clipped* "ws.scm")
+ (*clm-array-print-length* "ws.scm")
+ (*clm-player* "ws.scm")
+ (*clm-notehook* "ws.scm")
+ (*clm-with-sound-depth* "ws.scm")
+ (*clm-default-frequency* "ws.scm")
+ (*clm-delete-reverb* "ws.scm")
+ (*to-snd* "ws.scm")
+ (*clm-search-list* "ws.scm")
+ (*definstrument-hook* "ws.scm")
;; these are hidden in defgenerator
- (list 'make-abcos "generators.scm")
- (list 'make-absin "generators.scm")
- (list 'make-adjustable-oscil "generators.scm")
- (list 'make-adjustable-sawtooth-wave "generators.scm")
- (list 'make-adjustable-square-wave "generators.scm")
- (list 'make-adjustable-triangle-wave "generators.scm")
- (list 'make-asyfm "generators.scm")
- (list 'make-bess "generators.scm")
- (list 'make-blackman "generators.scm")
- (list 'make-brown-noise "generators.scm")
- (list 'make-dblsum "generators.scm")
- (list 'make-eoddcos "generators.scm")
- (list 'make-ercos "generators.scm")
- (list 'make-erssb "generators.scm")
- (list 'make-exponentially-weighted-moving-average "generators.scm")
- (list 'make-flocsig "generators.scm")
- (list 'make-fmssb "generators.scm")
- (list 'make-green-noise "generators.scm")
- (list 'make-green-noise-interp "generators.scm")
- (list 'make-izcos "generators.scm")
- (list 'make-j0evencos "generators.scm")
- (list 'make-j0j1cos "generators.scm")
- (list 'make-j2cos "generators.scm")
- (list 'make-jjcos "generators.scm")
- (list 'make-jncos "generators.scm")
- (list 'make-jpcos "generators.scm")
- (list 'make-jycos "generators.scm")
- (list 'make-k2cos "generators.scm")
- (list 'make-k2sin "generators.scm")
- (list 'make-k2ssb "generators.scm")
- (list 'make-k3sin "generators.scm")
- (list 'make-krksin "generators.scm")
- (list 'make-moving-autocorrelation "generators.scm")
- (list 'make-moving-fft "generators.scm")
- (list 'make-moving-length "generators.scm")
- (list 'make-moving-pitch "generators.scm")
- (list 'make-moving-rms "generators.scm")
- (list 'make-moving-scentroid "generators.scm")
- (list 'make-moving-spectrum "generators.scm")
- (list 'make-moving-sum "generators.scm")
- (list 'make-moving-variance "generators.scm")
- (list 'make-n1cos "generators.scm")
- (list 'make-nchoosekcos "generators.scm")
- (list 'make-ncos2 "generators.scm")
- (list 'make-ncos4 "generators.scm")
- (list 'make-nkssb "generators.scm")
- (list 'make-noddcos "generators.scm")
- (list 'make-noddsin "generators.scm")
- (list 'make-noddssb "generators.scm")
- (list 'make-noid "generators.scm")
- (list 'make-npcos "generators.scm")
- (list 'make-nrcos "generators.scm")
- (list 'make-nrsin "generators.scm")
- (list 'make-nrssb "generators.scm")
- (list 'make-nsincos "generators.scm")
- (list 'make-nssb "generators.scm")
- (list 'make-nxy1cos "generators.scm")
- (list 'make-nxy1sin "generators.scm")
- (list 'make-nxycos "generators.scm")
- (list 'make-nxysin "generators.scm")
- (list 'make-pink-noise "generators.scm")
- (list 'make-polyoid "generators.scm")
- (list 'make-r2k!cos "generators.scm")
- (list 'make-r2k2cos "generators.scm")
- (list 'make-rcos "generators.scm")
- (list 'make-rk!cos "generators.scm")
- (list 'make-rk!ssb "generators.scm")
- (list 'make-rkcos "generators.scm")
- (list 'make-rkoddssb "generators.scm")
- (list 'make-rksin "generators.scm")
- (list 'make-rkssb "generators.scm")
- (list 'make-round-interp "generators.scm")
- (list 'make-rssb "generators.scm")
- (list 'make-rxycos "generators.scm")
- (list 'make-rxysin "generators.scm")
- (list 'make-safe-rxycos "generators.scm")
- (list 'make-sinc-train "generators.scm")
- (list 'make-table-lookup-with-env "generators.scm")
- (list 'make-tanhsin "generators.scm")
- (list 'make-wave-train-with-env "generators.scm")
- (list 'make-waveshape "generators.scm")
- (list 'make-weighted-moving-average "generators.scm")
- (list 'nssb? "generators.scm")
- (list 'nxysin? "generators.scm")
- (list 'nxycos? "generators.scm")
- (list 'nxy1cos? "generators.scm")
- (list 'nxy1sin? "generators.scm")
- (list 'noddsin? "generators.scm")
- (list 'noddcos? "generators.scm")
- (list 'noddssb? "generators.scm")
- (list 'ncos2? "generators.scm")
- (list 'npcos? "generators.scm")
- (list 'nrsin? "generators.scm")
- (list 'nrcos? "generators.scm")
- (list 'nrssb? "generators.scm")
- (list 'nkssb? "generators.scm")
- (list 'nsincos? "generators.scm")
- (list 'n1cos? "generators.scm")
- (list 'rcos? "generators.scm")
- (list 'rssb? "generators.scm")
- (list 'rxysin? "generators.scm")
- (list 'rxycos? "generators.scm")
- (list 'safe-rxycos? "generators.scm")
- (list 'ercos? "generators.scm")
- (list 'erssb? "generators.scm")
- (list 'eoddcos? "generators.scm")
- (list 'rkcos? "generators.scm")
- (list 'rksin? "generators.scm")
- (list 'rkssb? "generators.scm")
- (list 'rk!cos? "generators.scm")
- (list 'rk!ssb? "generators.scm")
- (list 'r2k!cos? "generators.scm")
- (list 'k2sin? "generators.scm")
- (list 'k2cos? "generators.scm")
- (list 'k2ssb? "generators.scm")
- (list 'dblsum? "generators.scm")
- (list 'rkoddssb? "generators.scm")
- (list 'krksin? "generators.scm")
- (list 'abcos? "generators.scm")
- (list 'absin? "generators.scm")
- (list 'r2k2cos? "generators.scm")
- (list 'asyfm? "generators.scm")
- (list 'bess? "generators.scm")
- (list 'jjcos? "generators.scm")
- (list 'j0evencos? "generators.scm")
- (list 'j2cos? "generators.scm")
- (list 'jpcos? "generators.scm")
- (list 'jncos? "generators.scm")
- (list 'j0j1cos? "generators.scm")
- (list 'jycos? "generators.scm")
- (list 'blackman "generators.scm")
- (list 'blackman? "generators.scm")
- (list 'fmssb? "generators.scm")
- (list 'k3sin? "generators.scm")
- (list 'izcos? "generators.scm")
- (list 'adjustable-square-wave? "generators.scm")
- (list 'adjustable-triangle-wave? "generators.scm")
- (list 'adjustable-sawtooth-wave? "generators.scm")
- (list 'adjustable-oscil? "generators.scm")
- (list 'round-interp? "generators.scm")
- (list 'nchoosekcos? "generators.scm")
- (list 'sinc-train? "generators.scm")
- (list 'pink-noise? "generators.scm")
- (list 'brown-noise? "generators.scm")
- (list 'green-noise? "generators.scm")
- (list 'green-noise-interp? "generators.scm")
- (list 'moving-sum? "generators.scm")
- (list 'moving-variance? "generators.scm")
- (list 'moving-rms? "generators.scm")
- (list 'moving-length? "generators.scm")
- (list 'weighted-moving-average? "generators.scm")
- (list 'exponentially-weighted-moving-average? "generators.scm")
- (list 'polyoid "generators.scm")
- (list 'polyoid-tn "generators.scm")
- (list 'polyoid-un "generators.scm")
- (list 'noid "generators.scm")
- (list 'waveshape? "generators.scm")
- (list 'waveshape "generators.scm")
- (list 'tanhsin? "generators.scm")
- (list 'moving-fft? "generators.scm")
- (list 'moving-spectrum? "generators.scm")
- (list 'moving-scentroid? "generators.scm")
- (list 'moving-autocorrelation? "generators.scm")
- (list 'moving-pitch? "generators.scm")
- (list 'flocsig? "generators.scm")
-
- (list 'vector-for-each "r7rs.scm")
- (list 'string-for-each "r7rs.scm")
- (list 'list-copy "r7rs.scm")
- (list 'r7rs-string-fill! "r7rs.scm")
- (list 'char-foldcase "r7rs.scm")
- (list 'exact-integer? "r7rs.scm")
- (list 'inexact "r7rs.scm")
- (list 'exact "r7rs.scm")
- (list 'truncate-quotient "r7rs.scm")
- (list 'truncate-remainder "r7rs.scm")
- (list 'floor-remainder "r7rs.scm")
- (list 'open-binary-input-file "r7rs.scm")
- (list 'open-binary-output-file "r7rs.scm")
- (list 'bytevector-length "r7rs.scm")
- (list 'write-bytevector "r7rs.scm")
- (list 'open-input-bytevector "r7rs.scm")
- (list 'open-output-bytevector "r7rs.scm")
- (list 'read-u8 "r7rs.scm")
- (list 'write-u8 "r7rs.scm")
- (list 'u8-ready? "r7rs.scm")
- (list 'peek-u8 "r7rs.scm")
- (list 'write-simple "r7rs.scm")
- (list 'raise "r7rs.scm")
- (list 'raise-continuable "r7rs.scm")
- (list 'interaction-environment "r7rs.scm")
- (list 'jiffies-per-second "r7rs.scm")
- (list 'current-jiffy "r7rs.scm")
- (list 'current-second "r7rs.scm")
- (list 'get-environment-variable "r7rs.scm")
- (list 'get-environment-variables "r7rs.scm")
- (list 'r7rs-file-exists? "r7rs.scm")
- (list 'os-type "r7rs.scm")
- (list 'cpu-architecture "r7rs.scm")
- (list 'machine-name "r7rs.scm")
- (list 'os-version "r7rs.scm")
- (list 'implementation-name "r7rs.scm")
- (list 'implementation-version "r7rs.scm")
- (list 'box-type? "r7rs.scm")
- (list 'make-box-type "r7rs.scm")
- (list 'define-library "r7rs.scm")
- (list 'define-record-type "r7rs.scm")
- (list 'define-values "r7rs.scm")
+ (make-abcos "generators.scm")
+ (make-absin "generators.scm")
+ (make-adjustable-oscil "generators.scm")
+ (make-adjustable-sawtooth-wave "generators.scm")
+ (make-adjustable-square-wave "generators.scm")
+ (make-adjustable-triangle-wave "generators.scm")
+ (make-asyfm "generators.scm")
+ (make-bess "generators.scm")
+ (make-blackman "generators.scm")
+ (make-brown-noise "generators.scm")
+ (make-dblsum "generators.scm")
+ (make-eoddcos "generators.scm")
+ (make-ercos "generators.scm")
+ (make-erssb "generators.scm")
+ (make-exponentially-weighted-moving-average "generators.scm")
+ (make-flocsig "generators.scm")
+ (make-fmssb "generators.scm")
+ (make-green-noise "generators.scm")
+ (make-green-noise-interp "generators.scm")
+ (make-izcos "generators.scm")
+ (make-j0evencos "generators.scm")
+ (make-j0j1cos "generators.scm")
+ (make-j2cos "generators.scm")
+ (make-jjcos "generators.scm")
+ (make-jncos "generators.scm")
+ (make-jpcos "generators.scm")
+ (make-jycos "generators.scm")
+ (make-k2cos "generators.scm")
+ (make-k2sin "generators.scm")
+ (make-k2ssb "generators.scm")
+ (make-k3sin "generators.scm")
+ (make-krksin "generators.scm")
+ (make-moving-autocorrelation "generators.scm")
+ (make-moving-fft "generators.scm")
+ (make-moving-length "generators.scm")
+ (make-moving-pitch "generators.scm")
+ (make-moving-rms "generators.scm")
+ (make-moving-scentroid "generators.scm")
+ (make-moving-spectrum "generators.scm")
+ (make-moving-sum "generators.scm")
+ (make-moving-variance "generators.scm")
+ (make-n1cos "generators.scm")
+ (make-nchoosekcos "generators.scm")
+ (make-ncos2 "generators.scm")
+ (make-ncos4 "generators.scm")
+ (make-nkssb "generators.scm")
+ (make-noddcos "generators.scm")
+ (make-noddsin "generators.scm")
+ (make-noddssb "generators.scm")
+ (make-noid "generators.scm")
+ (make-npcos "generators.scm")
+ (make-nrcos "generators.scm")
+ (make-nrsin "generators.scm")
+ (make-nrssb "generators.scm")
+ (make-nsincos "generators.scm")
+ (make-nssb "generators.scm")
+ (make-nxy1cos "generators.scm")
+ (make-nxy1sin "generators.scm")
+ (make-nxycos "generators.scm")
+ (make-nxysin "generators.scm")
+ (make-pink-noise "generators.scm")
+ (make-polyoid "generators.scm")
+ (make-r2k!cos "generators.scm")
+ (make-r2k2cos "generators.scm")
+ (make-rcos "generators.scm")
+ (make-rk!cos "generators.scm")
+ (make-rk!ssb "generators.scm")
+ (make-rkcos "generators.scm")
+ (make-rkoddssb "generators.scm")
+ (make-rksin "generators.scm")
+ (make-rkssb "generators.scm")
+ (make-round-interp "generators.scm")
+ (make-rssb "generators.scm")
+ (make-rxycos "generators.scm")
+ (make-rxysin "generators.scm")
+ (make-safe-rxycos "generators.scm")
+ (make-sinc-train "generators.scm")
+ (make-table-lookup-with-env "generators.scm")
+ (make-tanhsin "generators.scm")
+ (make-wave-train-with-env "generators.scm")
+ (make-waveshape "generators.scm")
+ (make-weighted-moving-average "generators.scm")
+ (nssb? "generators.scm")
+ (nxysin? "generators.scm")
+ (nxycos? "generators.scm")
+ (nxy1cos? "generators.scm")
+ (nxy1sin? "generators.scm")
+ (noddsin? "generators.scm")
+ (noddcos? "generators.scm")
+ (noddssb? "generators.scm")
+ (ncos2? "generators.scm")
+ (npcos? "generators.scm")
+ (nrsin? "generators.scm")
+ (nrcos? "generators.scm")
+ (nrssb? "generators.scm")
+ (nkssb? "generators.scm")
+ (nsincos? "generators.scm")
+ (n1cos? "generators.scm")
+ (rcos? "generators.scm")
+ (rssb? "generators.scm")
+ (rxysin? "generators.scm")
+ (rxycos? "generators.scm")
+ (safe-rxycos? "generators.scm")
+ (ercos? "generators.scm")
+ (erssb? "generators.scm")
+ (eoddcos? "generators.scm")
+ (rkcos? "generators.scm")
+ (rksin? "generators.scm")
+ (rkssb? "generators.scm")
+ (rk!cos? "generators.scm")
+ (rk!ssb? "generators.scm")
+ (r2k!cos? "generators.scm")
+ (k2sin? "generators.scm")
+ (k2cos? "generators.scm")
+ (k2ssb? "generators.scm")
+ (dblsum? "generators.scm")
+ (rkoddssb? "generators.scm")
+ (krksin? "generators.scm")
+ (abcos? "generators.scm")
+ (absin? "generators.scm")
+ (r2k2cos? "generators.scm")
+ (asyfm? "generators.scm")
+ (bess? "generators.scm")
+ (jjcos? "generators.scm")
+ (j0evencos? "generators.scm")
+ (j2cos? "generators.scm")
+ (jpcos? "generators.scm")
+ (jncos? "generators.scm")
+ (j0j1cos? "generators.scm")
+ (jycos? "generators.scm")
+ (blackman "generators.scm")
+ (blackman? "generators.scm")
+ (fmssb? "generators.scm")
+ (k3sin? "generators.scm")
+ (izcos? "generators.scm")
+ (adjustable-square-wave? "generators.scm")
+ (adjustable-triangle-wave? "generators.scm")
+ (adjustable-sawtooth-wave? "generators.scm")
+ (adjustable-oscil? "generators.scm")
+ (round-interp? "generators.scm")
+ (nchoosekcos? "generators.scm")
+ (sinc-train? "generators.scm")
+ (pink-noise? "generators.scm")
+ (brown-noise? "generators.scm")
+ (green-noise? "generators.scm")
+ (green-noise-interp? "generators.scm")
+ (moving-sum? "generators.scm")
+ (moving-variance? "generators.scm")
+ (moving-rms? "generators.scm")
+ (moving-length? "generators.scm")
+ (weighted-moving-average? "generators.scm")
+ (exponentially-weighted-moving-average? "generators.scm")
+ (polyoid "generators.scm")
+ (polyoid-tn "generators.scm")
+ (polyoid-un "generators.scm")
+ (noid "generators.scm")
+ (waveshape? "generators.scm")
+ (waveshape "generators.scm")
+ (tanhsin? "generators.scm")
+ (moving-fft? "generators.scm")
+ (moving-spectrum? "generators.scm")
+ (moving-scentroid? "generators.scm")
+ (moving-autocorrelation? "generators.scm")
+ (moving-pitch? "generators.scm")
+ (flocsig? "generators.scm")
+
+ (vector-for-each "r7rs.scm")
+ (string-for-each "r7rs.scm")
+ (list-copy "r7rs.scm")
+ (r7rs-string-fill! "r7rs.scm")
+ (char-foldcase "r7rs.scm")
+ (exact-integer? "r7rs.scm")
+ (inexact "r7rs.scm")
+ (exact "r7rs.scm")
+ (truncate-quotient "r7rs.scm")
+ (truncate-remainder "r7rs.scm")
+ (floor-remainder "r7rs.scm")
+ (open-binary-input-file "r7rs.scm")
+ (open-binary-output-file "r7rs.scm")
+ (bytevector-length "r7rs.scm")
+ (write-bytevector "r7rs.scm")
+ (open-input-bytevector "r7rs.scm")
+ (open-output-bytevector "r7rs.scm")
+ (read-u8 "r7rs.scm")
+ (write-u8 "r7rs.scm")
+ (u8-ready? "r7rs.scm")
+ (peek-u8 "r7rs.scm")
+ (write-simple "r7rs.scm")
+ (raise "r7rs.scm")
+ (raise-continuable "r7rs.scm")
+ (interaction-environment "r7rs.scm")
+ (jiffies-per-second "r7rs.scm")
+ (current-jiffy "r7rs.scm")
+ (current-second "r7rs.scm")
+ (get-environment-variable "r7rs.scm")
+ (get-environment-variables "r7rs.scm")
+ (r7rs-file-exists? "r7rs.scm")
+ (os-type "r7rs.scm")
+ (cpu-architecture "r7rs.scm")
+ (machine-name "r7rs.scm")
+ (os-version "r7rs.scm")
+ (implementation-name "r7rs.scm")
+ (implementation-version "r7rs.scm")
+ (box-type? "r7rs.scm")
+ (make-box-type "r7rs.scm")
+ (define-library "r7rs.scm")
+ (define-record-type "r7rs.scm")
+ (define-values "r7rs.scm")
- (list 'c?r "stuff.scm")
- (list 'do* "stuff.scm")
- (list 'typecase "stuff.scm")
- (list 'enum "stuff.scm")
- (list 'while "stuff.scm")
- (list 'let-temporarily "stuff.scm")
- (list 'define-class "stuff.scm")
- (list 'elambda "stuff.scm")
- (list 'value->symbol "stuff.scm")
- (list 'progv "stuff.scm")
- (list 'reflective-let "stuff.scm")
- (list 'reflective-probe "stuff.scm")
- (list 'reactive-let "stuff.scm")
- (list 'reactive-let* "stuff.scm")
- (list 'reactive-lambda* "stuff.scm")
- (list 'pretty-print "write.scm")
- (list 'fully-macroexpand "stuff.scm")
- (list '*mock-vector* "mockery.scm")
- (list '*mock-port* "mockery.scm")
- (list '*mock-symbol* "mockery.scm")
- (list '*mock-pair* "mockery.scm")
- (list '*mock-number* "mockery.scm")
- (list '*mock-char* "mockery.scm")
- (list '*mock-string* "mockery.scm")
- (list '*mock-hash-table* "mockery.scm")
-
- (list 'lint "lint.scm")
- (list 'html-lint "lint.scm")
-
- (list 'c-define "cload.scm")
-
- (list 'moog? "moog.scm")
- (list 'make-moog "moog.scm")
-
- (list 'snd-clm23.scm "clm23.scm")
- (list 'snd-edit123.scm "edit123.scm")
-; (list 'snd-snd11.scm "snd11.scm")
- (list 'snd-new-backgrounds.scm "new-backgrounds.scm")
- (list 'snd-new-effects.scm "new-effects.scm")
- (list 'snd-bess1.scm "bess1.scm")
- (list 'snd-bess.scm "bess.scm")
- (list 'snd-edit-menu.scm "edit-menu.scm")
- (list 'snd-effects-utils.scm "effects-utils.scm")
- (list 'snd-fft-menu.scm "fft-menu.scm")
- (list 'snd-fmv.scm "fmv.scm")
- (list 'snd-gtk-effects.scm "gtk-effects.scm")
- (list 'snd-gtk-effects-utils.scm "gtk-effects-utils.scm")
- (list 'snd-snd-gl.scm "snd-gl.scm")
- (list 'snd-snd-gtk.scm "snd-gtk.scm")
- (list 'snd-snd-motif.scm "snd-motif.scm")
- (list 'snd-special-menu.scm "special-menu.scm")
- (list 'snd-marks-menu.scm "marks-menu.scm")
- (list 'snd-misc.scm "misc.scm")
- (list 'snd-xm-enved.scm "xm-enved.scm")
-
- (list 'snd-ws.scm "ws.scm")
- (list 'sndlib-ws.scm "sndlib-ws.scm")
-
+ (c?r "stuff.scm")
+ (do* "stuff.scm")
+ (typecase "stuff.scm")
+ (enum "stuff.scm")
+ (while "stuff.scm")
+ (let-temporarily "stuff.scm")
+ (define-class "stuff.scm")
+ (elambda "stuff.scm")
+ (value->symbol "stuff.scm")
+ (progv "stuff.scm")
+ (reflective-let "stuff.scm")
+ (reflective-probe "stuff.scm")
+ (reactive-let "stuff.scm")
+ (reactive-let* "stuff.scm")
+ (reactive-lambda* "stuff.scm")
+ (pretty-print "write.scm")
+ (fully-macroexpand "stuff.scm")
+ (*mock-vector* "mockery.scm")
+ (*mock-port* "mockery.scm")
+ (*mock-symbol* "mockery.scm")
+ (*mock-pair* "mockery.scm")
+ (*mock-number* "mockery.scm")
+ (*mock-char* "mockery.scm")
+ (*mock-string* "mockery.scm")
+ (*mock-hash-table* "mockery.scm")
+
+ (lint "lint.scm")
+ (html-lint "lint.scm")
+
+ (c-define "cload.scm")
+
+ (moog? "moog.scm")
+ (make-moog "moog.scm")
+
+ (snd-clm23.scm "clm23.scm")
+ (snd-edit123.scm "edit123.scm")
+; (snd-snd11.scm "snd11.scm")
+ (snd-new-backgrounds.scm "new-backgrounds.scm")
+ (snd-new-effects.scm "new-effects.scm")
+ (snd-bess1.scm "bess1.scm")
+ (snd-bess.scm "bess.scm")
+ (snd-edit-menu.scm "edit-menu.scm")
+ (snd-effects-utils.scm "effects-utils.scm")
+ (snd-fft-menu.scm "fft-menu.scm")
+ (snd-fmv.scm "fmv.scm")
+ (snd-gtk-effects.scm "gtk-effects.scm")
+ (snd-gtk-effects-utils.scm "gtk-effects-utils.scm")
+ (snd-snd-gl.scm "snd-gl.scm")
+ (snd-snd-gtk.scm "snd-gtk.scm")
+ (snd-snd-motif.scm "snd-motif.scm")
+ (snd-special-menu.scm "special-menu.scm")
+ (snd-marks-menu.scm "marks-menu.scm")
+ (snd-misc.scm "misc.scm")
+ (snd-xm-enved.scm "xm-enved.scm")
+
+ (snd-ws.scm "ws.scm")
+ (sndlib-ws.scm "sndlib-ws.scm")
))
;; still missing (if not above):
@@ -852,13 +851,11 @@
(set! flst (cons name flst)))))
ce)
(hash-table-set! names file flst)))
- (list
- (list '*libm* "libm.scm")
- (list '*libgdbm* "libgdbm.scm")
- (list '*libdl* "libdl.scm")
- (list '*libc* "libc.scm")
- (list '*libgsl* "libgsl.scm")
- ))
+ '((*libm* "libm.scm")
+ (*libgdbm* "libgdbm.scm")
+ (*libdl* "libdl.scm")
+ (*libc* "libc.scm")
+ (*libgsl* "libgsl.scm")))
(apropos-1 (rootlet))
@@ -949,10 +946,11 @@
(set! xrefing #f))
(if id-pos
- (let* ((start (- (char-position #\" dline id-pos) id-pos)) ; (substring dline id-pos)))
+ (let* ((start (- (char-position #\" dline id-pos) id-pos)) ; (substring dline id-pos)))
(end-start (+ id-pos start 2))
- (end (- (char-position #\" dline end-start) end-start)) ; (substring dline (+ id-pos start 2))))
- (name (substring dline (+ id-pos start 1) (+ id-pos start 2 end)))
+ (name (substring dline
+ (+ id-pos start 1)
+ (- (+ id-pos start (char-position #\" dline end-start) 2) end-start)))
(sym-name (string->symbol name)))
(if (not (hash-table-ref ids sym-name))
(hash-table-set! ids sym-name 0)
@@ -1021,7 +1019,7 @@
(do ((i 0 (+ i 1)))
((= i n))
(set! (tnames ctr)
- (clean-and-downcase-first-char (names i) capitalized (topics i) (files i)))
+ (clean-and-downcase-first-char (names i) capitalized (files i)))
(if (positive? (length (ind-sortby (tnames ctr))))
(set! ctr (+ ctr 1))))
@@ -1192,8 +1190,7 @@
(let* ((line (substring (ind-name (tnames i)) 8))
(dpos (char-position #\> line))
(url (substring line 1 (- dpos 1)))
- (epos (char-position #\< line))
- (ind (substring line (+ dpos 1) epos))
+ (ind (substring line (+ dpos 1) (char-position #\< line)))
(gpos (string-position ">" ind)))
(if gpos
(set! ind (string-append (substring ind 0 gpos)
@@ -1405,8 +1402,8 @@
(format () "~A[~D]: ~A without start? ~A from [~D:~D] (commands: ~A)~%"
file linectr closer line (+ start 2) i commands))
((not (memq closer '(ul tr td table small sub blockquote p details summary
- a A i b title pre span h1 h2 h3 code body html
- em head h4 sup map smaller bigger th tbody div)))
+ a A i b title pre span h1 h2 h3 code body html
+ em head h4 sup map smaller bigger th tbody div)))
(set! commands (remove-all closer commands)))
(else
(if (not (eq? (car commands) closer))
@@ -1551,7 +1548,7 @@
(begin
(let ((min-epos (char-position #\space dline)))
(set! epos (char-position #\> dline))
- (if (and (number? min-epos)
+ (if (and (real? min-epos)
(< min-epos epos))
(set! epos min-epos)))
diff --git a/tools/makegl.scm b/tools/makegl.scm
index 411ef9f..ebbaea1 100755
--- a/tools/makegl.scm
+++ b/tools/makegl.scm
@@ -47,8 +47,7 @@
(substring data (if sp2 (values (+ sp1 1) sp2) sp1))))
(define (caddr-str data)
- (let* ((sp1 (char-position #\space data))
- (sp2 (char-position #\space data (+ sp1 1)))
+ (let* ((sp2 (char-position #\space data (+ (char-position #\space data) 1)))
(sp3 (char-position #\space data (+ sp2 1))))
(substring data (if sp3 (+ sp2 1) sp2))))
@@ -107,9 +106,9 @@
(define (no-stars type)
(if (string=? type "Display*")
- "Display"
+ (copy "Display")
(if (string=? type "XVisualInfo*")
- "XVisualInfo"
+ (copy "XVisualInfo")
(let ((len (length type))
(val (string-copy type)))
(do ((i 0 (+ i 1)))
@@ -133,8 +132,8 @@
(let ((reftype #f))
(let ((given-name (substring args (+ 1 sp) (if (= i (- len 1)) (+ i 1) i))))
(case (given-name 0)
- ((#\@) (set! data (cons (list type (substring given-name 1 (length given-name)) 'null) data)))
- ((#\#) (set! data (cons (list type (substring given-name 1 (length given-name)) 'opt) data)))
+ ((#\@) (set! data (cons (list type (substring given-name 1) 'null) data)))
+ ((#\#) (set! data (cons (list type (substring given-name 1) 'opt) data)))
((#\[)
(set! reftype (deref-type (list type)))
(set! data (cons (list type (substring given-name 1 (- (length given-name) 1)) given-name) data)))
@@ -223,11 +222,9 @@
("BOOLEAN" . "C_bool_to_Xen_boolean")
("ULONG" . "C_ulong_to_Xen_ulong"))
string=?) => cdr)
- ((not (string-ci=? str "String"))
- (format #f "~A unknown" str))
- ((string=? (car typ) "guchar*")
- "C_to_Xen_String")
- (else "C_string_to_Xen_string")))
+ ((not (string-ci=? str "String")) (format #f "~A unknown" str))
+ ((string=? (car typ) "guchar*") (copy "C_to_Xen_String"))
+ (else (copy "C_string_to_Xen_string"))))
(define (xen-to-c-macro-name str)
(cond ((assoc str '(("INT" . "Xen_integer_to_C_int")
@@ -235,7 +232,7 @@
("BOOLEAN" . "Xen_boolean_to_C_bool")
("ULONG" . "Xen_ulong_to_C_ulong"))
string=?) => cdr)
- ((string-ci=? str "String") "Xen_string_to_C_string")
+ ((string-ci=? str "String") (copy "Xen_string_to_C_string"))
(else (format #f "~A unknown" str))))
(define (type-it type)
@@ -263,7 +260,7 @@
("ULONG" . "ulong")
("DOUBLE" . "number")) string=?)
=> cdr)
- (else (apply string (map char-downcase (cdr typ))))))))
+ (else (string-downcase (cdr typ)))))))
(begin
(hey "#define Xen_is_~A(Arg) 1~%" (no-stars type))
(hey "#define Xen_to_C_~A(Arg) ((gpointer)Arg)~%" (no-stars type)))))))
@@ -507,7 +504,7 @@
(return-type (cadr data))
(args (caddr data))
(argslen (length args))
- (cargs (length args))
+ (cargs argslen)
(refargs (ref-args args))
(xgargs (- cargs refargs))
(argstr (cadddr data))
@@ -766,7 +763,7 @@
(let ((sig (make-signature f)))
(if (pair? sig)
(let ((count (signatures sig)))
- (set! (signatures sig) (if (not count) 0 (+ count 1)))))))
+ (set! (signatures sig) (if (not (real? count)) 0 (+ count 1)))))))
lst))
(make-signatures funcs)
diff --git a/tools/makexg.scm b/tools/makexg.scm
index c18caab..d3f9734 100755
--- a/tools/makexg.scm
+++ b/tools/makexg.scm
@@ -21,9 +21,9 @@
(define all-types ())
;;; preset some types that are getting confused
-(set! types (list "GdkEventMotion*" "gdouble*" "GdkEventAny*" "GdkEvent*" "gboolean*"
+(set! types (list "GdkEventMotion*" "gdouble*" "GdkEventAny*" "GdkEvent*" "gboolean*" "GdkWindow*"
"cairo_t*" "cairo_font_options_t*" "PangoFontDescription*"))
-(set! all-types (list "GdkEventMotion*" "gdouble*" "GdkEventAny*" "GdkEvent*"
+(set! all-types (list "GdkEventMotion*" "gdouble*" "GdkEventAny*" "GdkEvent*" "GdkWindow*"
"cairo_t*" "cairo_font_options_t*" "PangoFontDescription*"))
(define idlers (list "g_source_remove" "g_idle_remove_by_data"
@@ -41,7 +41,8 @@
"GdkEventScroll*" "GdkEventSelection*" "GdkEventSetting*" "GdkEventVisibility*" "GdkEventWindowState*" "GdkGCValues*"
"GdkGeometry*" "GdkInterpType" "GdkModifierType*" "GdkPixbufDestroyNotify" "GdkScreen**" "GdkSegment*" "GdkWChar*"
"GdkWMDecoration*" "GdkWindowAttr*" "GtkAccelLabel*" "GtkAccelMapForeach" "GtkAccessible*" "GtkActionEntry*"
- "GtkAlignment*" "GtkAllocation*" "GtkArrow*" "GtkAspectFrame*" "GtkBin*" "GtkBox*" "GtkButton*" "GtkButtonBox*"
+ "GtkAlignment*" "GtkAllocation*"
+ "GtkArrow*" "GtkAspectFrame*" "GtkBin*" "GtkBox*" "GtkButton*" "GtkButtonBox*"
"GtkCalendar*" "GtkCellLayout*" "GtkCellLayoutDataFunc" "GtkCellRendererPixbuf*" "GtkCellRendererText*" "GtkCellRendererToggle*"
"GtkCheckMenuItem*" "GtkClipboardTargetsReceivedFunc"
"GtkCombo*" "GtkComboBox*" "GtkComboBoxEntry*" "GtkContainer*" "GtkCurve*" "GtkDialog*" "GtkDrawingArea*" "GtkEditable*"
@@ -100,7 +101,8 @@
;"GdkFunction" ;"GtkWrapBoxPacking"
"GtkLinkButton*" "GtkActivatable*" "GtkOrientable*" "GtkCellArea*"
;"GdkNativeWindow"
- "GdkRectangle*" "PangoRenderer*" "cairo_glyph_t**" "cairo_text_cluster_t**"
+ "GdkRectangle*"
+ "PangoRenderer*" "cairo_glyph_t**" "cairo_text_cluster_t**"
; "cairo_text_cluster_flags_t"
; "cairo_rectangle_int_t"
"cairo_rectangle_t*"
@@ -124,6 +126,7 @@
"GtkGestureSwipe*" "GtkGestureZoom*" "GtkGestureController*" "GtkEventController*"
"GtkGLArea*" "GtkStyleContext*" "GtkPopoverMenu*" "GtkSearchEntry*" "GtkStackSidebar*"
+ "GtkShortcutsWindow*"
))
(define no-xen-p
@@ -140,7 +143,7 @@
"GtkImageType" "GtkTreeModelFlags" "gint8" "gshort" "guint8" "lambda" "gboolean*"
"time_t" ;"GtkWindowGroup*"
- "GtkSettings*" ;"GdkDevice*"
+ ;"GtkSettings*" ;"GdkDevice*"
"GtkScaleButton*"
"GtkPrintOperationResult" "GtkPrintStatus" "GtkSizeRequestMode"
"GdkEventAny*" "GdkDeviceManager*"
@@ -163,7 +166,7 @@
"GtkImageType" "GtkTreeModelFlags" "etc" "gshort" "gboolean*"
;"GtkWindowGroup*"
- "time_t" "GtkSettings*" ;"GdkDevice*"
+ "time_t" ;"GtkSettings*" ;"GdkDevice*"
"GtkScaleButton*"
"GtkPrintOperationResult" "GtkPrintStatus"
"GdkDeviceManager*" "GdkEventAny*" "GtkSizeRequestMode"
@@ -180,8 +183,7 @@
(substring data (if sp2 (values (+ sp1 1) sp2) sp1))))
(define (caddr-str data)
- (let* ((sp1 (char-position #\space data))
- (sp2 (char-position #\space data (+ sp1 1)))
+ (let* ((sp2 (char-position #\space data (+ (char-position #\space data) 1)))
(sp3 (char-position #\space data (+ sp2 1))))
(substring data (if sp3 (+ sp2 1) sp2))))
@@ -253,6 +255,20 @@
(if (char=? (val i) #\*)
(set! (val i) #\_)))))
+(define cairo-funcs ())
+(define cairo-png-funcs ())
+(define cairo-ints ())
+(define cairo-types ())
+
+(define cairo-funcs-810 ())
+(define cairo-ints-810 ())
+(define cairo-types-810 ())
+
+(define cairo-funcs-912 ())
+(define cairo-ints-912 ())
+(define cairo-types-912 ())
+(define cairo-strings-912 ())
+
(define (parse-args args extra)
(let ((data ())
(sp -1)
@@ -271,9 +287,9 @@
(let ((reftype #f))
(let ((given-name (substring args (+ 1 sp) (if (= i (- len 1)) (+ i 1) i))))
(case (given-name 0)
- ((#\@) (set! data (cons (list type (substring given-name 1 (length given-name)) 'null) data)))
- ((#\#) (set! data (cons (list type (substring given-name 1 (length given-name)) 'opt) data)))
- ((#\&) (set! data (cons (list type (substring given-name 1 (length given-name)) 'set) data)))
+ ((#\@) (set! data (cons (list type (substring given-name 1) 'null) data)))
+ ((#\#) (set! data (cons (list type (substring given-name 1) 'opt) data)))
+ ((#\&) (set! data (cons (list type (substring given-name 1) 'set) data)))
((#\[ #\{ #\|)
(set! reftype (deref-type (list type)))
(set! data (cons (list type (substring given-name 1 (- (length given-name) 1)) given-name) data)))
@@ -567,6 +583,7 @@
(cons "GdkAxisUse" "INT")
(cons "GdkAxisFlags" "INT")
(cons "GdkDeviceToolType" "INT")
+ (cons "GdkSubpixelLayout" "INT")
))
(define (c-to-xen-macro-name type str)
@@ -576,8 +593,8 @@
("ULONG" . "C_ulong_to_Xen_ulong"))
string=?) => cdr)
((not (string=? str "String")) (format #f "~A unknown" str))
- ((string=? type "guchar*") "C_to_Xen_String")
- (else "C_string_to_Xen_string")))
+ ((string=? type "guchar*") (copy "C_to_Xen_String"))
+ (else (copy "C_string_to_Xen_string"))))
(define (xen-to-c-macro-name str)
(cond ((assoc str '(("INT" . "Xen_integer_to_C_int")
@@ -605,7 +622,7 @@
("DOUBLE" . "number")
("ULONG" . "ulong"))
string=?) => cdr)
- (else (apply string (map char-downcase c-name)))))))
+ (else (string-downcase c-name))))))
((not c-name) ; void special case
(if (not (member type no-xen-p))
(hey "#define Xen_is_~A(Arg) 1~%" (no-stars type)))
@@ -642,6 +659,14 @@
(no-stars type)
type)))))
+
+(define callback-name car)
+(define callback-type cadr)
+(define callback-func caddr)
+(define callback-args cadddr)
+(define (callback-gc func) (func 4))
+(define (callback-version func) (and (> (length func) 5) (func 5)))
+
(define (func-type strs)
(call-with-exit
(lambda (return)
@@ -662,22 +687,20 @@
(define-macro (make-fnc vname)
- (let* ((cfnc-name (string-append "CFNC-" vname))
- (cfnc (string->symbol cfnc-name))
- (g-fnc (string->symbol (string-append "g-" vname)))
- (types (string->symbol (string-append "types-" vname)))
- (funcs (string->symbol (string-append "funcs-" vname)))
- (strfnc (string->symbol (string-append "CSTR-" vname)))
- (strings (string->symbol (string-append "strings-" vname)))
- (names (string->symbol (string-append "names-" vname)))
- (intfnc (string->symbol (string-append "CINT-" vname)))
- (ints (string->symbol (string-append "ints-" vname)))
- (castfnc (string->symbol (string-append "CCAST-" vname)))
- (casts (string->symbol (string-append "casts-" vname)))
- (chkfnc (string->symbol (string-append "CCHK-" vname)))
- (checks (string->symbol (string-append "checks-" vname)))
- (withfnc (string->symbol (string-append "with-" vname)))
- )
+ (let ((cfnc (symbol "CFNC-" vname))
+ (g-fnc (symbol "g-" vname))
+ (types (symbol "types-" vname))
+ (funcs (symbol "funcs-" vname))
+ (strfnc (symbol "CSTR-" vname))
+ (strings (symbol "strings-" vname))
+ (names (symbol "names-" vname))
+ (intfnc (symbol "CINT-" vname))
+ (ints (symbol "ints-" vname))
+ (castfnc (symbol "CCAST-" vname))
+ (casts (symbol "casts-" vname))
+ (chkfnc (symbol "CCHK-" vname))
+ (checks (symbol "checks-" vname))
+ (withfnc (symbol "with-" vname)))
`(begin
(define ,funcs ())
(define ,strings ())
@@ -759,20 +782,6 @@
(make-fnc "3.20")
(make-fnc "3.22")
-(define cairo-funcs ())
-(define cairo-png-funcs ())
-(define cairo-ints ())
-(define cairo-types ())
-
-(define cairo-funcs-810 ())
-(define cairo-ints-810 ())
-(define cairo-types-810 ())
-
-(define cairo-funcs-912 ())
-(define cairo-ints-912 ())
-(define cairo-types-912 ())
-(define cairo-strings-912 ())
-
(define callbacks
(list
; (list 'lambda2 ; unnamed gdk_window_invalidate_maybe_recurse argument (2.90.6 now)
@@ -991,21 +1000,16 @@
(parse-args "GtkRecentInfo* a GtkRecentInfo* b lambda_data func_info" 'callback)
'permanent)
+
(list 'GdkSeatGrabPrepareFunc
"void"
"prepare_func"
(parse-args "GdkSeat* seat GdkWindow* window lambda_data func_info" 'g-3.20)
'permanent
"3.20")
- ))
+ ))
-(define callback-name car)
-(define callback-type cadr)
-(define callback-func caddr)
-(define callback-args cadddr)
-(define (callback-gc func) (func 4))
-(define (callback-version func) (and (> (length func) 5) (func 5)))
(define (find-callback test)
(let find-callback-1 ((test test)
@@ -1778,7 +1782,7 @@
"Xen_car")))
(for-each
(lambda (arg)
- (hey (substring " " 0 castlen))
+ (hey (make-string castlen #\space))
(if (string=? (car arg) "lambda_data")
(hey "Xen_cadr((Xen)func_info),~%")
(hey "C_to_Xen_~A(~A~A),~%"
@@ -1788,7 +1792,7 @@
"")
(cadr arg))))
args)
- (hey (substring " " 0 castlen))
+ (hey (make-string castlen #\space))
(hey "__func__)")
(if void?
(hey ";~%")
@@ -2441,7 +2445,7 @@
(hey "{~%")
(hey " GdkEventKey *e;~%")
(hey " e = Xen_to_C_GdkEventKey_(event);~%")
-(hey " if (e) return(C_int_to_Xen_integer((int)(e->keyval))); return(XEN_ZERO);~%")
+(hey " if (e) return(C_int_to_Xen_integer((int)(e->keyval)));~% return(XEN_ZERO);~%")
(hey "}~%~%")
(hey "static Xen xen_list_to_c_array(Xen val, Xen type)~%")
@@ -2669,7 +2673,7 @@
(let ((sig (make-signature f)))
(if (pair? sig)
(let ((count (signatures sig)))
- (set! (signatures sig) (if (not count) 0 (+ count 1)))))))
+ (set! (signatures sig) (if (not (real? count)) 0 (+ count 1)))))))
lst))
(make-signatures funcs)
diff --git a/tools/tauto.scm b/tools/tauto.scm
index 334ef6a..eead2a3 100644
--- a/tools/tauto.scm
+++ b/tools/tauto.scm
@@ -35,7 +35,7 @@
(define-constant constants (list #f #t () #\a (/ most-positive-fixnum) (/ -1 most-positive-fixnum) 1.5+i
"hi455" :key hi: 'hi (list 1) (list 1 2) (cons 1 2) (list (list 1 2)) (list (list 1)) (list ()) #()
1/0+i 0+0/0i 0+1/0i 1+0/0i 0/0+0i 0/0+0/0i 1+1/0i 0/0+i cons ''2
- 1+i 1+1e10i 1e15+1e15i 0+1e18i 1e18 (integer->char 255) (string (integer->char 255)) 1e308
+ 1+i 1+1e10i 1e15+1e15i 0+1e18i 1e18 #\xff (string #\xff) 1e308
most-positive-fixnum most-negative-fixnum (- most-positive-fixnum 1) (+ most-negative-fixnum 1)
-1 0 0.0 1 1.5 1.0-1.0i 3/4 #\null -63 (make-hash-table) (hash-table '(a . 2) '(b . 3))
'((1 2) (3 4)) '((1 (2)) (((3) 4))) "" (list #(1) "1") '(1 2 . 3) (list (cons 'a 2) (cons 'b 3))
@@ -46,12 +46,12 @@
quasiquote macroexpand begin let letrec* if case cond (call-with-exit (lambda (goto) goto))
(with-baffle (call/cc (lambda (cc) cc)))
(string #\a #\null #\b) #2d((1 2) (3 4)) (inlet 'a 2 'b 3)
- #<undefined> #<unspecified> (make-int-vector 3 0) (make-float-vector 3 -1.4)
+ #<undefined> #<unspecified> (make-int-vector 3) (make-float-vector 3 -1.4)
(make-vector '(2 3) "hi") #("hiho" "hi" "hoho") (make-shared-vector (make-int-vector '(2 3) 1) '(6))
(make-shared-vector (make-shared-vector (make-float-vector '(2 3) 1.0) '(6)) '(2 2))
(vector-ref #2d((#(1 2 3)) (#(3 4 5))) 0 0) (define-macro (m a) `(+ ,a 1))
(c-pointer 0) (c-pointer -1) :readable :else (define-bacro* (m (a 1)) `(+ ,a 1))
- (byte-vector 0 1 2) (byte-vector) (byte-vector 255 0 127) (make-iterator (vector '(a . 2)))
+ (byte-vector 0 1 2) (byte-vector) (byte-vector 255 0 127) (make-iterator #((a . 2)))
(lambda (dir) 1.0) (float-vector) (make-float-vector '(2 32))
'((a . 1)) #(1) '((((A . B) C . D) (E . F) G . H) ((I . J) K . L) (M . N) O . P)
@@ -181,25 +181,25 @@
(define (test-sym sym)
(if (and (not (memq sym baddies))
(defined? sym))
- (let ((f (symbol->value sym)))
- (let ((argn (and (or (procedure? f) (let? f)) (arity f))))
- (if argn
- (let ((bottom (car argn))
- (top (min (cdr argn) max-args))
- (strname (symbol->string sym)))
- (if (not (memq (strname 0) '(#\{ #\[ #\()))
- (begin
- (if (< top bottom)
- (format *stderr* ";~A (bottom: ~A, top: ~A)...~%" sym bottom top))
- ;(format *stderr* ";~A...~%" sym)
- (set! low bottom)
- (if (positive? (cdr argn))
- (let ((sig (cond ((eq? sym 'append)
- (let ((lst (list 'list?)))
- (set-cdr! lst lst)))
- ((procedure-signature f) => copy))))
- (map-values sig)
- (autotest f () 0 top (if (pair? sig) (cdr sig) ()))))))))))))
+ (let* ((f (symbol->value sym))
+ (argn (and (or (procedure? f) (let? f)) (arity f))))
+ (if argn
+ (let ((bottom (car argn))
+ (top (min (cdr argn) max-args))
+ (strname (symbol->string sym)))
+ (if (not (memv (strname 0) '(#\{ #\[ #\()))
+ (begin
+ (if (< top bottom)
+ (format *stderr* ";~A (bottom: ~A, top: ~A)...~%" sym bottom top))
+ ;(format *stderr* ";~A...~%" sym)
+ (set! low bottom)
+ (if (positive? (cdr argn))
+ (let ((sig (cond ((eq? sym 'append)
+ (let ((lst (list 'list?)))
+ (set-cdr! lst lst)))
+ ((procedure-signature f) => copy))))
+ (map-values sig)
+ (autotest f () 0 top (if (pair? sig) (cdr sig) ())))))))))))
(define (all)
(let ((st (symbol-table)))
diff --git a/tools/tcopy.scm b/tools/tcopy.scm
index e81b269..9b86d6d 100644
--- a/tools/tcopy.scm
+++ b/tools/tcopy.scm
@@ -209,8 +209,8 @@
(set! vecs (cons (make-vector size i) vecs))
(set! ivecs (cons (make-int-vector size i) ivecs))
(set! fvecs (cons (make-float-vector size (* i 1.0)) fvecs))
- (set! ifvecs (cons (make-vector size (if (even? i) (* i 1.0) i) #t) ifvecs))
- (set! allvecs (cons (make-vector size (if (even? i) (* i 1.0) i) (not (zero? (modulo i 3)))) allvecs))
+ (set! ifvecs (cons ((if (even? i) make-float-vector make-int-vector) size (if (even? i) (* i 1.0) i)) ifvecs))
+ (set! allvecs (cons (make-vector size (if (even? i) (* i 1.0) i)) allvecs))
(set! lsts (cons (make-list size i) lsts)))
(let ((lst (apply append lsts))
(vec (apply vector-append vecs))
diff --git a/tools/tform.scm b/tools/tform.scm
index e2cc8b3..dfaba47 100644
--- a/tools/tform.scm
+++ b/tools/tform.scm
@@ -36,9 +36,9 @@
quasiquote macroexpand cond-expand begin let letrec* if case cond (call-with-exit (lambda (goto) goto))
(with-baffle (call/cc (lambda (cc) cc)))
(string #\a #\null #\b) #2d((1 2) (3 4)) (inlet 'a 2 'b 3)
- #<undefined> #<unspecified> (make-vector 3 0 #t) (make-vector 3 -1.4 #t)
- (make-vector '(2 3) "hi") #("hiho" "hi" "hoho") (make-shared-vector (make-vector '(2 3) 1 #t) '(6))
- (make-shared-vector (make-shared-vector (make-vector '(2 3) 1.0 #t) '(6)) '(2 2))
+ #<undefined> #<unspecified> (make-int-vector 3 0) (make-float-vector 3 -1.4)
+ (make-vector '(2 3) "hi") #("hiho" "hi" "hoho") (make-shared-vector (make-int-vector '(2 3) 1) '(6))
+ (make-shared-vector (make-shared-vector (make-float-vector '(2 3) 1.0) '(6)) '(2 2))
(vector-ref #2d((#(1 2 3)) (#(3 4 5))) 0 0) (define-macro (m a) `(+ ,a 1))
(c-pointer 0) (c-pointer -1) :readable *s7* else (define-bacro* (m (a 1)) `(+ ,a 1))
(byte-vector 0 1 2) (byte-vector) (byte-vector 255 0 127) (make-iterator (vector '(a . 2)))
diff --git a/tools/va.scm b/tools/va.scm
index c00333b..5da7cc6 100755
--- a/tools/va.scm
+++ b/tools/va.scm
@@ -45,7 +45,7 @@
(not (= count (- precount 1))))
(format () "calloc ~D->~D: ~A~%" precount count line))
(loop (read-line file #t))))))))
- (list "calloc" "malloc" "realloc"))
+ '("calloc" "malloc" "realloc"))
(load "lint.scm")
@@ -85,102 +85,100 @@
; (if (string=? (substring filename (- (length filename) 3)) "scm")
; (lint filename))
)
- (list
- "analog-filter.scm"
- "animals.scm"
- "autosave.scm"
- "bess.scm"
- "bess1.scm"
- "big-gens.scm"
- "binary-io.scm"
- "bird.scm"
- "clean.scm"
- "clm-ins.scm"
- "clm23.scm"
- "dlocsig.scm"
- "draw.scm"
- "dsp.scm"
- "edit-menu.scm"
- "edit123.scm"
- "effects-utils.scm"
- "env.scm"
- "enved.scm"
- "examp.scm"
- "expandn.scm"
- "extensions.scm"
- "fade.scm"
- "fft-menu.scm"
- "fmv.scm"
+ '("analog-filter.scm"
+ "animals.scm"
+ "autosave.scm"
+ "bess.scm"
+ "bess1.scm"
+ "big-gens.scm"
+ "binary-io.scm"
+ "bird.scm"
+ "clean.scm"
+ "clm-ins.scm"
+ "clm23.scm"
+ "dlocsig.scm"
+ "draw.scm"
+ "dsp.scm"
+ "edit-menu.scm"
+ "edit123.scm"
+ "effects-utils.scm"
+ "env.scm"
+ "enved.scm"
+ "examp.scm"
+ "expandn.scm"
+ "extensions.scm"
+ "fade.scm"
+ "fft-menu.scm"
+ "fmv.scm"
; "frame.scm"
- "freeverb.scm"
- "fullmix.scm"
- "generators.scm"
- "grani.scm"
- "gtk-effects-utils.scm"
- "gtk-effects.scm"
- "hooks.scm"
- "index.scm"
- "jcrev.scm"
- "jcvoi.scm"
- "lint.scm"
- "maraca.scm"
- "marks-menu.scm"
- "marks.scm"
- "maxf.scm"
- "misc.scm"
- "mix.scm"
+ "freeverb.scm"
+ "fullmix.scm"
+ "generators.scm"
+ "grani.scm"
+ "gtk-effects-utils.scm"
+ "gtk-effects.scm"
+ "hooks.scm"
+ "index.scm"
+ "jcrev.scm"
+ "jcvoi.scm"
+ "lint.scm"
+ "maraca.scm"
+ "marks-menu.scm"
+ "marks.scm"
+ "maxf.scm"
+ "misc.scm"
+ "mix.scm"
; "mixer.scm"
- "moog.scm"
- "musglyphs.scm"
- "nb.scm"
- "new-backgrounds.scm"
- "new-effects.scm"
- "noise.scm"
- "nrev.scm"
- "numerics.scm"
- "peak-phases.scm"
- "piano.scm"
- "play.scm"
- "poly.scm"
- "prc95.scm"
- "primes.scm"
- "pvoc.scm"
- "rgb.scm"
+ "moog.scm"
+ "musglyphs.scm"
+ "nb.scm"
+ "new-backgrounds.scm"
+ "new-effects.scm"
+ "noise.scm"
+ "nrev.scm"
+ "numerics.scm"
+ "peak-phases.scm"
+ "piano.scm"
+ "play.scm"
+ "poly.scm"
+ "prc95.scm"
+ "primes.scm"
+ "pvoc.scm"
+ "rgb.scm"
; "rtio.scm"
- "rubber.scm"
- "s7-slib-init.scm"
- "s7test.scm"
- "selection.scm"
- "singer.scm"
- "snd-gl.scm"
- "snd-gtk.scm"
- "snd-motif.scm"
- "snd-test.scm"
-; "snd11.scm"
-; "snd12.scm"
- "snddiff.scm"
- "sndlib-ws.scm"
- "sndwarp.scm"
- "special-menu.scm"
- "spectr.scm"
- "spokenword.scm"
- "stochastic.scm"
- "strad.scm"
- "v.scm"
- "write.scm"
- "ws.scm"
- "xm-enved.scm"
- "zip.scm"
-
- "snd.html"
- "sndscm.html"
- "grfsnd.html"
- "extsnd.html"
- "sndclm.html"
- "fm.html"
- "s7.html"
- "sndlib.html"
- )))
+ "rubber.scm"
+ "s7-slib-init.scm"
+ "s7test.scm"
+ "selection.scm"
+ "singer.scm"
+ "snd-gl.scm"
+ "snd-gtk.scm"
+ "snd-motif.scm"
+ "snd-test.scm"
+ ; "snd11.scm"
+ ; "snd12.scm"
+ "snddiff.scm"
+ "sndlib-ws.scm"
+ "sndwarp.scm"
+ "special-menu.scm"
+ "spectr.scm"
+ "spokenword.scm"
+ "stochastic.scm"
+ "strad.scm"
+ "v.scm"
+ "write.scm"
+ "ws.scm"
+ "xm-enved.scm"
+ "zip.scm"
+
+ "snd.html"
+ "sndscm.html"
+ "grfsnd.html"
+ "extsnd.html"
+ "sndclm.html"
+ "fm.html"
+ "s7.html"
+ "sndlib.html")))
(va)
diff --git a/tools/xgdata.scm b/tools/xgdata.scm
index f6f8374..77f7b66 100644
--- a/tools/xgdata.scm
+++ b/tools/xgdata.scm
@@ -4494,7 +4494,7 @@
(CFNC "GdkDisplay* gdk_display_open gchar* display_name")
(CFNC "gchar* gdk_display_get_name GdkDisplay* display")
;;; 3.9.0 (CFNC "int gdk_display_get_n_screens GdkDisplay* display")
-(CFNC "GdkScreen* gdk_display_get_screen GdkDisplay* display int screen_num")
+;;; 3.20 (CFNC "GdkScreen* gdk_display_get_screen GdkDisplay* display int screen_num")
(CFNC "GdkScreen* gdk_display_get_default_screen GdkDisplay* display")
;;; 2.99.0 (CFNC "void gdk_display_pointer_ungrab GdkDisplay* display guint32 time")
;;; 2.99.0 (CFNC "void gdk_display_keyboard_ungrab GdkDisplay* display guint32 time")
@@ -5133,7 +5133,7 @@
;;; 2.13.6. (CFNC "GtkWidget* gtk_file_chooser_widget_new_with_backend GtkFileChooserAction action gchar* backend")
;;; ;(CFNC-gtk2 "void gtk_rc_reset_styles GtkSettings* settings")
;;;(CFNC "void gtk_text_layout_set_keyboard_direction GtkTextLayout* layout GtkTextDirection keyboard_dir")
-;;;GtkTextLayout is buggy
+;;;GtkTextLayout is buggy (and now gone)
(CFNC "GList* gtk_widget_list_mnemonic_labels GtkWidget* widget") ; FREE (g_list_free)
(CFNC "void gtk_widget_add_mnemonic_label GtkWidget* widget GtkWidget* label")
(CFNC "void gtk_widget_remove_mnemonic_label GtkWidget* widget GtkWidget* label")
@@ -9240,7 +9240,7 @@
(CFNC-3.20 "void gtk_widget_queue_allocate GtkWidget* widget")
(CFNC-3.20 "void gtk_widget_set_focus_on_click GtkWidget* widget gboolean focus_on_click")
(CFNC-3.20 "gboolean gtk_widget_get_focus_on_click GtkWidget* widget")
-(CFNC-3.20 "void gtk_widget_get_allocated_size GtkWidget* widget GtkAllocation* [allocation] int* [baseline]")
+;(CFNC-3.20 "void gtk_widget_get_allocated_size GtkWidget* widget GtkAllocation* [allocation] int* [baseline]")
;;; 3.19.3:
@@ -9278,6 +9278,7 @@
(CFNC-3.20 "gboolean gtk_text_iter_starts_tag GtkTextIter* iter GtkTextTag* @tag")
+
(CCAST-3.20 "GDK_SEAT(object)" "GdkSeat*")
(CCHK-3.20 "GDK_IS_SEAT(object)" "GdkSeat*")
@@ -9295,7 +9296,7 @@
(CFNC-3.20 "GdkDragContext* gdk_drag_begin_from_point GdkWindow* window GdkDevice* device GList* targets gint x_root gint y_root")
(CFNC-3.20 "void gdk_drag_drop_done GdkDragContext* context gboolean success")
(CFNC-3.20 "void gdk_drag_context_set_hotspot GdkDragContext* context gint hot_x gint hot_y")
-(CFNC-3.20 "GdkGrabStatus gdk_seat_grab GdkSeat* seat GdkWindow* window GdkSeatCapabilities capabilities gboolean owner_events GdkCursor* cursor const GdkEvent* event GdkSeatGrabPrepareFunc prepare_func lambda_data #prepare_func_data")
+(CFNC-3.20 "GdkGrabStatus gdk_seat_grab GdkSeat* seat GdkWindow* window GdkSeatCapabilities capabilities gboolean owner_events GdkCursor* cursor GdkEvent* event GdkSeatGrabPrepareFunc prepare_func lambda_data #func_info") ; the name func_info is built-in
(CFNC-3.20 "void gdk_seat_ungrab GdkSeat* seat")
(CFNC-3.20 "GdkDisplay* gdk_seat_get_display GdkSeat* seat")
(CFNC-3.20 "GdkSeatCapabilities gdk_seat_get_capabilities GdkSeat* seat")
@@ -9316,7 +9317,7 @@
;;; 3.19.8:
-(CFNC-3.20 "void gtk_render_background_get_clip GtkStyleContext* context gdouble x gdouble y gdouble width gdouble height GdkRectangle* [out_clip]")
+;(CFNC-3.20 "void gtk_render_background_get_clip GtkStyleContext* context gdouble x gdouble y gdouble width gdouble height GdkRectangle* [out_clip]")
;;; 3.19.9:
@@ -9326,8 +9327,9 @@
(CINT-3.20 "GDK_DRAG_CANCEL_USER_CANCELLED" "GdkDragCancelReason")
(CINT-3.20 "GDK_DRAG_CANCEL_ERROR" "GdkDragCancelReason")
-(CFNC-3.20 "gboolean gtk_text_layout_get_iter_at_pixel GtkTextLayout* layout GtkTextIter* iter gint x gint y")
-(CFNC-3.20 "gboolean gtk_text_layout_get_iter_at_position GtkTextLayout* layout GtkTextIter* iter gint* [trailing] gint x gint y")
+;;; (CFNC-3.20 "gboolean gtk_text_layout_get_iter_at_pixel GtkTextLayout* layout GtkTextIter* iter gint x gint y")
+;;; (CFNC-3.20 "gboolean gtk_text_layout_get_iter_at_position GtkTextLayout* layout GtkTextIter* iter gint* [trailing] gint x gint y")
+;;; GtkTextLayout is private for GtkTextView
;;; these two used to return void so we do them by hand in makexg.scm
;;; (CFNC-3.20 "gboolean gtk_text_view_get_iter_at_position GtkTextView* text_view GtkTextIter* iter gint* [trailing] gint x gint y")
@@ -9384,3 +9386,34 @@
(CFNC-3.22 "gboolean gtk_gl_area_get_use_es GtkGLArea* area")
(CFNC-3.22 "guint gdk_device_tool_get_serial GdkDeviceTool* tool")
+
+;;; 3.21.2:
+
+(CCAST-3.22 "GDK_MONITOR(object)" "GdkMonitor*")
+(CCHK-3.22 "GDK_IS_MONITOR(object)" "GdkMonitor*")
+
+(CINT-3.22 "GDK_SUBPIXEL_LAYOUT_UNKNOWN" "GdkSubpixelLayout")
+(CINT-3.22 "GDK_SUBPIXEL_LAYOUT_NONE" "GdkSubpixelLayout")
+(CINT-3.22 "GDK_SUBPIXEL_LAYOUT_HORIZONTAL_RGB" "GdkSubpixelLayout")
+(CINT-3.22 "GDK_SUBPIXEL_LAYOUT_HORIZONTAL_BGR" "GdkSubpixelLayout")
+(CINT-3.22 "GDK_SUBPIXEL_LAYOUT_VERTICAL_RGB" "GdkSubpixelLayout")
+(CINT-3.22 "GDK_SUBPIXEL_LAYOUT_VERTICAL_BGR" "GdkSubpixelLayout")
+
+(CFNC-3.22 "int gdk_display_get_n_monitors GdkDisplay* display")
+(CFNC-3.22 "GdkMonitor* gdk_display_get_monitor GdkDisplay* display int monitor_num")
+(CFNC-3.22 "GdkMonitor* gdk_display_get_primary_monitor GdkDisplay* display")
+(CFNC-3.22 "GdkMonitor* gdk_display_get_monitor_at_point GdkDisplay* display int x int y")
+(CFNC-3.22 "GdkMonitor* gdk_display_get_monitor_at_window GdkDisplay* display GdkWindow* window")
+(CFNC-3.22 "gboolean gdk_event_get_pointer_emulated GdkEvent* event")
+(CFNC-3.22 "gtk_menu_place_on_monitor GtkMenu* menu GdkMonitor* monitor")
+(CFNC-3.22 "GdkDisplay* gdk_monitor_get_display GdkMonitor* monitor")
+(CFNC-3.22 "void gdk_monitor_get_geometry GdkMonitor* monitor GdkRectangle* geometry")
+(CFNC-3.22 "void gdk_monitor_get_workarea GdkMonitor* monitor GdkRectangle* workarea")
+(CFNC-3.22 "int gdk_monitor_get_width_mm GdkMonitor* monitor")
+(CFNC-3.22 "int gdk_monitor_get_height_mm GdkMonitor* monitor")
+(CFNC-3.22 "char* gdk_monitor_get_manufacturer GdkMonitor* monitor" 'const)
+(CFNC-3.22 "char* gdk_monitor_get_model GdkMonitor* monitor" 'const)
+(CFNC-3.22 "int gdk_monitor_get_scale_factor GdkMonitor* monitor")
+(CFNC-3.22 "int gdk_monitor_get_refresh_rate GdkMonitor* monitor")
+(CFNC-3.22 "GdkSubpixelLayout gdk_monitor_get_subpixel_layout GdkMonitor* monitor")
+(CFNC-3.22 "gboolean gdk_monitor_is_primary GdkMonitor* monitor")
diff --git a/v.scm b/v.scm
index 5b3b015..8f4b8ea 100644
--- a/v.scm
+++ b/v.scm
@@ -65,7 +65,7 @@
(if (>= (* 2 fm3-rat frequency) *clm-srate*) (set! fm3-rat 1.0))
(let ((index1 (or fm1-index (min pi (* maxdev (/ 5.0 logfreq)))))
- (index2 (or fm2-index (min pi (* maxdev 3.0 (/ (- 8.5 logfreq) (+ 3.0 (* frequency .001)))))))
+ (index2 (or fm2-index (min pi (/ (* maxdev 3.0 (- 8.5 logfreq)) (+ 3.0 (* frequency 0.001))))))
(index3 (or fm3-index (min pi (* maxdev (/ 4.0 sqrtfreq)))))
(easy-case (and (zero? noise-amount)
(equal? fm1-env fm2-env)
diff --git a/vct.c b/vct.c
index 68b2cc0..b11b0bd 100644
--- a/vct.c
+++ b/vct.c
@@ -79,17 +79,17 @@ mus_float_t *mus_vct_data(vct *v) {return(v->data);}
#if HAVE_SCHEME
#define S_make_vct "make-float-vector"
-#define S_vct_add "float-vector-add!"
-#define S_vct_subtract "float-vector-subtract!"
+#define S_vct_add "float-vector-add!"
+#define S_vct_subtract "float-vector-subtract!"
#define S_vct_copy "float-vector-copy"
#define S_vct_length "float-vector-length"
-#define S_vct_multiply "float-vector-multiply!"
-#define S_vct_offset "float-vector-offset!"
+#define S_vct_multiply "float-vector-multiply!"
+#define S_vct_offset "float-vector-offset!"
#define S_vct_ref "float-vector-ref"
-#define S_vct_scale "float-vector-scale!"
-#define S_vct_abs "float-vector-abs!"
-#define S_vct_fill "float-vector-fill!"
-#define S_vct_set "float-vector-set!"
+#define S_vct_scale "float-vector-scale!"
+#define S_vct_abs "float-vector-abs!"
+#define S_vct_fill "float-vector-fill!"
+#define S_vct_set "float-vector-set!"
#define S_vct_peak "float-vector-peak"
#define S_vct_equal "float-vector-equal?"
#define S_is_vct "float-vector?"
@@ -97,7 +97,7 @@ mus_float_t *mus_vct_data(vct *v) {return(v->data);}
#define S_vct_to_list "float-vector->list"
#define S_vector_to_vct "vector->float-vector"
#define S_vct_to_vector "float-vector->vector"
-#define S_vct_move "float-vector-move!"
+#define S_vct_move "float-vector-move!"
#define S_vct_subseq "float-vector-subseq"
#define S_vct_reverse "float-vector-reverse!"
#define S_vct_to_string "float-vector->string"
@@ -106,17 +106,17 @@ mus_float_t *mus_vct_data(vct *v) {return(v->data);}
#define A_VCT "a float-vector"
#else
#define S_make_vct "make-vct"
-#define S_vct_add "vct-add!"
-#define S_vct_subtract "vct-subtract!"
+#define S_vct_add "vct-add!"
+#define S_vct_subtract "vct-subtract!"
#define S_vct_copy "vct-copy"
#define S_vct_length "vct-length"
-#define S_vct_multiply "vct-multiply!"
-#define S_vct_offset "vct-offset!"
+#define S_vct_multiply "vct-multiply!"
+#define S_vct_offset "vct-offset!"
#define S_vct_ref "vct-ref"
-#define S_vct_scale "vct-scale!"
-#define S_vct_abs "vct-abs!"
-#define S_vct_fill "vct-fill!"
-#define S_vct_set "vct-set!"
+#define S_vct_scale "vct-scale!"
+#define S_vct_abs "vct-abs!"
+#define S_vct_fill "vct-fill!"
+#define S_vct_set "vct-set!"
#define S_vct_peak "vct-peak"
#define S_vct_equal "vct-equal?"
#define S_is_vct "vct?"
@@ -124,7 +124,7 @@ mus_float_t *mus_vct_data(vct *v) {return(v->data);}
#define S_vct_to_list "vct->list"
#define S_vector_to_vct "vector->vct"
#define S_vct_to_vector "vct->vector"
-#define S_vct_move "vct-move!"
+#define S_vct_move "vct-move!"
#define S_vct_subseq "vct-subseq"
#define S_vct_reverse "vct-reverse!"
#define S_vct_to_string "vct->string"
@@ -1774,7 +1774,7 @@ Xen_wrap_7_args(g_vct_interpolate_w, g_vct_interpolate)
void mus_vct_init(void)
{
#if HAVE_SCHEME
- s7_pointer pl_ff, pl_rf, pl_fff, pl_fffi, pl_ffr, pl_pf, pl_bffr, pl_ftt, pl_ffii, pl_ffiif, pl_sf;
+ s7_pointer pl_ff, pl_rf, pl_fff, pl_fffi, pl_ffr, pl_pf, pl_bffr, pl_ftt, pl_ffiib, pl_ffiif, pl_sf;
#else
vct_tag = Xen_make_object_type("Vct", sizeof(vct));
@@ -1863,7 +1863,7 @@ void mus_vct_init(void)
pl_ffr = s7_make_signature(s7, 3, f, f, r);
pl_bffr = s7_make_signature(s7, 4, b, f, f, r);
pl_fffi = s7_make_signature(s7, 4, f, f, f, i);
- pl_ffii = s7_make_signature(s7, 4, f, f, i, i);
+ pl_ffiib = s7_make_signature(s7, 5, f, f, i, i, b);
pl_ffiif = s7_make_signature(s7, 5, f, f, i, i, f);
}
#endif
@@ -1874,7 +1874,7 @@ void mus_vct_init(void)
Xen_define_typed_procedure(S_vct_offset, g_vct_offset_w, 2, 0, 0, H_vct_offsetB, pl_ffr);
Xen_define_typed_procedure(S_vct_peak, g_vct_peak_w, 1, 0, 0, H_vct_peak, pl_rf);
Xen_define_typed_procedure(S_vct_peak_and_location, g_vct_peak_and_location_w, 1, 0, 0, H_vct_peak_and_location, pl_pf);
- Xen_define_typed_procedure(S_vct_move, g_vct_move_w, 3, 1, 0, H_vct_moveB, pl_ffii);
+ Xen_define_typed_procedure(S_vct_move, g_vct_move_w, 3, 1, 0, H_vct_moveB, pl_ffiib);
Xen_define_typed_procedure(S_vct_subseq, g_vct_subseq_w, 2, 2, 0, H_vct_subseq, pl_ffiif);
Xen_define_typed_procedure(S_vct_copy, g_vct_copy_w, 1, 0, 0, H_vct_copy, pl_ff);
diff --git a/write.scm b/write.scm
index 23f91d0..ac3f7b7 100644
--- a/write.scm
+++ b/write.scm
@@ -14,141 +14,143 @@
(lambda* (obj (port (current-output-port)) (column 0))
- (define newlines 0)
-
- (define (pretty-print-1 obj port column)
- (define (spaces n)
- (set! newlines (+ newlines 1))
- (format port "~%~NC" (+ n *pretty-print-left-margin*) #\space))
-
- (define (stacked-list lst col)
- (do ((p lst (cdr p)))
- ((not (pair? p)))
- (let ((added 0))
- (if (not (eq? p lst)) (spaces col))
- (let* ((str (object->string (car p)))
- (len (length str)))
- (if (and (keyword? (car p))
- (pair? (cdr p)))
- (begin
- (write (car p) port)
- (write-char #\space port)
- (set! added (+ 1 len))
- (set! p (cdr p))))
- (if (not (pair? p))
- (format port " . ~S" p)
- (if (and (pair? (car p))
- (pair? (cdar p))
- (null? (cddar p))
- (> len (/ *pretty-print-length* 2)))
- (begin
- (if (eq? (caar p) 'quote)
- (write-char #\' port)
- (begin
- (write-char #\( port)
- (pretty-print-1 (caar p) port col)
- (spaces (+ col 1))))
- (pretty-print-1 (cadar p) port (+ col 1))
- (if (not (eq? (caar p) 'quote))
- (write-char #\) port)))
- (pretty-print-1 (car p) port (+ col added))))))))
-
- (define (stacked-split-list lst col)
- (if (not (pair? lst))
- (write lst port)
+ (define pretty-print-1
+ (let ((newlines 0))
+ (lambda (obj port column)
+
+ (define (spaces n)
+ (set! newlines (+ newlines 1))
+ (format port "~%~NC" (+ n *pretty-print-left-margin*) #\space))
+
+ (define (stacked-list lst col)
(do ((p lst (cdr p)))
((not (pair? p)))
- (if (not (eq? p lst)) (spaces col))
- (write-char #\( port)
- (if (pair? (car p))
- (begin
- (write (caar p) port)
- (write-char #\space port)
- (if (and (pair? (cdar p))
- (symbol? (caar p)))
- (pretty-print-1 (cadar p) port (+ col (length (symbol->string (caar p))) 2))
- (write (cdar p) port)))
- (write (car p) port))
- (write-char #\) port))))
-
- (define (messy-number z)
- (if (real? z)
- (if (or (nan? z)
- (infinite? z))
- (object->string z)
- (if (= z pi)
- "pi"
- (format #f *pretty-print-float-format* z)))
- (format #f "~A~A~Ai"
- (messy-number (real-part z))
- (if (negative? (imag-part z)) "-" "+")
- (messy-number (abs (imag-part z))))))
-
- (define (any-keyword? lst)
- (and (pair? lst)
- (or (keyword? (car lst))
- (any-keyword? (cdr lst)))))
-
- (cond ((number? obj)
- (if (rational? obj)
- (write obj port)
- (display (messy-number obj) port)))
-
- ((pair? obj)
- (case (car obj)
-
- ((lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let
- call-with-input-string call-with-input-file call-with-output-file
- with-input-from-file with-input-from-string with-output-to-file)
- (if (not (and (pair? (cdr obj))
- (pair? (cddr obj))))
- (write obj port)
- (begin
- (format port "(~A ~A" (car obj) (cadr obj))
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))))
-
- ((defmacro defmacro*)
- (if (not (and (pair? (cdr obj))
- (pair? (cddr obj))))
- (write obj port)
- (begin
- (format port "(~A ~A ~A" (car obj) (cadr obj) (caddr obj))
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))))
-
- ((define)
- (if (not (pair? (cdr obj)))
- (write obj port)
- (begin
- (format port "(~A ~A " (car obj) (cadr obj))
- (if (pair? (cadr obj))
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
- (if (pair? (cddr obj))
- (let ((str (object->string (caddr obj))))
- (if (> (length str) 60)
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (pretty-print-1 (caddr obj) port (+ column *pretty-print-spacing*)))
- (write (caddr obj) port)))
- (write (cddr obj) port)))
- (write-char #\) port))))
-
- ((do)
- (if (not (pair? (cdr obj)))
- (write obj port)
- (begin
- (format port "(do (")
- (if (pair? (cadr obj))
- (stacked-list (cadr obj) (+ column 5)))
- (write-char #\) port)
- (if (not (pair? (cddr obj)))
- (write-char #\) port)
+ (let ((added 0))
+ (if (not (eq? p lst)) (spaces col))
+ (let ((len (length (object->string (car p)))))
+ (if (and (keyword? (car p))
+ (pair? (cdr p)))
+ (begin
+ (write (car p) port)
+ (write-char #\space port)
+ (set! added (+ 1 len))
+ (set! p (cdr p))))
+ (if (not (pair? p))
+ (format port " . ~S" p)
+ (if (and (pair? (car p))
+ (pair? (cdar p))
+ (null? (cddar p))
+ (> len (/ *pretty-print-length* 2)))
(begin
+ (if (eq? (caar p) 'quote)
+ (write-char #\' port)
+ (begin
+ (write-char #\( port)
+ (pretty-print-1 (caar p) port col)
+ (spaces (+ col 1))))
+ (pretty-print-1 (cadar p) port (+ col 1))
+ (if (not (eq? (caar p) 'quote))
+ (write-char #\) port)))
+ (pretty-print-1 (car p) port (+ col added))))))))
+
+ (define (stacked-split-list lst col)
+ (if (not (pair? lst))
+ (write lst port)
+ (do ((p lst (cdr p)))
+ ((not (pair? p)))
+ (if (not (eq? p lst)) (spaces col))
+ (write-char #\( port)
+ (if (pair? (car p))
+ (begin
+ (write (caar p) port)
+ (write-char #\space port)
+ (if (and (pair? (cdar p))
+ (symbol? (caar p)))
+ (pretty-print-1 (cadar p) port (+ col (length (symbol->string (caar p))) 2))
+ (write (cdar p) port)))
+ (write (car p) port))
+ (write-char #\) port))))
+
+ (define (messy-number z)
+ (if (real? z)
+ (if (or (nan? z)
+ (infinite? z))
+ (object->string z)
+ (if (= z pi)
+ (copy "pi")
+ (format #f *pretty-print-float-format* z)))
+ (format #f "~A~A~Ai"
+ (messy-number (real-part z))
+ (if (negative? (imag-part z)) "-" "+")
+ (messy-number (abs (imag-part z))))))
+
+ (define (any-keyword? lst)
+ (and (pair? lst)
+ (or (keyword? (car lst))
+ (any-keyword? (cdr lst)))))
+
+ (cond ((number? obj)
+ (if (rational? obj)
+ (write obj port)
+ (display (messy-number obj) port)))
+
+ ((pair? obj)
+ (case (car obj)
+
+ ((lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let
+ call-with-input-string call-with-input-file call-with-output-file
+ with-input-from-file with-input-from-string with-output-to-file)
+ (if (not (and (pair? (cdr obj))
+ (pair? (cddr obj))))
+ (write obj port)
+ (begin
+ (format port "(~A ~A" (car obj) (cadr obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))))
+
+ ((defmacro defmacro*)
+ (if (not (and (pair? (cdr obj))
+ (pair? (cddr obj))))
+ (write obj port)
+ (begin
+ (format port "(~A ~A ~A" (car obj) (cadr obj) (caddr obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))))
+
+ ((define)
+ (if (not (pair? (cdr obj)))
+ (write obj port)
+ (begin
+ (format port "(~A ~A " (car obj) (cadr obj))
+ (if (pair? (cadr obj))
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
+ (if (pair? (cddr obj))
+ (let ((str (object->string (caddr obj))))
+ (if (> (length str) 60)
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (pretty-print-1 (caddr obj) port (+ column *pretty-print-spacing*)))
+ (write (caddr obj) port)))
+ (write (cddr obj) port)))
+ (write-char #\) port))))
+
+ ((do)
+ (if (not (pair? (cdr obj)))
+ (write obj port)
+ (begin
+ (format port "(do ")
+ (if (list? (cadr obj))
+ (write-char #\( port)
+ (display (cadr obj) port))
+ (if (pair? (cadr obj))
+ (stacked-list (cadr obj) (+ column 5)))
+ (if (list? (cadr obj))
+ (write-char #\) port))
+ (when (pair? (cddr obj))
(spaces (+ column 4))
(let ((end (caddr obj)))
(if (< (length (object->string end)) (- *pretty-print-length* column))
@@ -161,286 +163,296 @@
(write-char #\) port))))
(when (pair? (cdddr obj))
(spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdddr obj) (+ column *pretty-print-spacing*)))
- (write-char #\) port))))))
-
- ((cond)
- (format port "(cond ")
- (do ((lst (cdr obj) (cdr lst)))
- ((not (pair? lst)))
- (if (not (eq? lst (cdr obj)))
- (spaces (+ column 6)))
- (if (not (pair? (car lst)))
- (write (car lst) port)
- (let* ((has=> (and (pair? (cdar lst))
- (eq? (cadar lst) '=>)))
- (extras (and (pair? (cdar lst))
- (pair? (cddar lst))
- (or (not has=>)
- (pair? (cdddar lst)))))
- (too-long (> (length (object->string (cdar lst))) 50)))
- (write-char #\( port)
- (let ((oldlines newlines))
- (pretty-print-1 (caar lst) port (+ column 7))
- (if (or extras
- (not (= oldlines newlines))
- too-long)
- (spaces (+ column 7))
+ (stacked-list (cdddr obj) (+ column *pretty-print-spacing*))))
+ (write-char #\) port))))
+
+ ((cond)
+ (format port "(cond ")
+ (do ((lst (cdr obj) (cdr lst)))
+ ((not (pair? lst)))
+ (if (not (eq? lst (cdr obj)))
+ (spaces (+ column 6)))
+ (if (not (pair? (car lst)))
+ (write (car lst) port)
+ (let* ((has=> (and (pair? (cdar lst))
+ (eq? (cadar lst) '=>)))
+ (extras (and (pair? (cdar lst))
+ (pair? (cddar lst))
+ (or (not has=>)
+ (pair? (cdddar lst)))))
+ (too-long (> (length (object->string (cdar lst))) 50)))
+ (write-char #\( port)
+ (let ((oldlines newlines))
+ (pretty-print-1 (caar lst) port (+ column 7))
+ (if (or extras
+ (not (= oldlines newlines))
+ too-long)
+ (spaces (+ column 7))
+ (if (and (pair? (cdar lst))
+ (or (not has=>)
+ (= oldlines newlines)))
+ (write-char #\space port)))
(if (and (pair? (cdar lst))
- (or (not has=>)
- (= oldlines newlines)))
- (write-char #\space port)))
- (if (and (pair? (cdar lst))
- (not extras)
- (not too-long))
- (begin
- (write (cadar lst) port)
- (when has=>
+ (not extras)
+ (not too-long))
+ (begin
+ (write (cadar lst) port)
+ (when has=>
+ (write-char #\space port)
+ (write (caddar lst) port)))
+ (if (not (null? (cdar lst)))
+ (stacked-list (cdar lst) (+ column 7)))))
+ (write-char #\) port))))
+ (write-char #\) port))
+
+ ((or and)
+ (if (> (length (object->string obj)) 40)
+ (begin
+ (format port "(~A " (car obj))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing* (length (symbol->string (car obj)))))
+ (write-char #\) port))
+ (write obj port)))
+
+ ((case)
+ (if (not (pair? (cdr obj)))
+ (write obj port)
+ (begin
+ (format port "(case ~A" (cadr obj)) ; send out the selector
+ (do ((lst (cddr obj) (cdr lst)))
+ ((not (pair? lst)))
+ (spaces (+ column *pretty-print-spacing*))
+ (if (not (pair? (car lst)))
+ (write (car lst) port)
+ (begin
+ (write-char #\( port)
+ (if (not (pair? (caar lst)))
+ (write (caar lst) port)
+ (let ((len (length (caar lst))))
+ (if (< len 6)
+ (write (caar lst) port)
+ (let ((p (caar lst)))
+ (write-char #\( port)
+ (do ((i 0 (+ i 6)))
+ ((>= i len))
+ (do ((j 0 (+ j 1)))
+ ((or (= j 6)
+ (null? p))
+ (if (pair? p) (spaces (+ column 4))))
+ (write (car p) port)
+ (set! p (cdr p))
+ (if (pair? p) (write-char #\space port))))
+ (write-char #\) port)))))
+ (if (not (null? (cdar lst))) ; null here is a bug in the input case statement
+ (if (and (pair? (cdar lst))
+ (null? (cddar lst))
+ (< (length (object->string (cadar lst))) 60))
+ (begin
+ (write-char #\space port)
+ (write (cadar lst) port))
+ (begin
+ (spaces (+ column 3))
+ (stacked-list (cdar lst) (+ column 3)))))
+ (write-char #\) port))))
+ (write-char #\) port))))
+
+ ((begin call-with-exit call/cc call-with-current-continuation with-baffle with-output-to-string call-with-output-string)
+ (format port "(~A" (car obj))
+ (if (pair? (cdr obj))
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
+ (write-char #\) port))
+
+ ((map for-each)
+ (let* ((objstr (object->string obj))
+ (strlen (length objstr)))
+ (if (< (+ column strlen) *pretty-print-length*)
+ (display objstr port)
+ (begin
+ (format port "(~A" (car obj))
+ (if (pair? (cdr obj))
+ (begin
(write-char #\space port)
- (write (caddar lst) port)))
- (if (not (null? (cdar lst)))
- (stacked-list (cdar lst) (+ column 7)))))
- (write-char #\) port))))
- (write-char #\) port))
-
- ((or and)
- (if (> (length (object->string obj)) 40)
- (begin
- (format port "(~A " (car obj))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing* (length (symbol->string (car obj)))))
- (write-char #\) port))
- (write obj port)))
-
- ((case)
- (if (not (pair? (cdr obj)))
- (write obj port)
- (begin
- (format port "(case ~A" (cadr obj)) ; send out the selector
- (do ((lst (cddr obj) (cdr lst)))
- ((not (pair? lst)))
- (spaces (+ column *pretty-print-spacing*))
- (if (not (pair? (car lst)))
- (write (car lst) port)
- (begin
- (write-char #\( port)
- (if (not (pair? (caar lst)))
- (write (caar lst) port)
- (let ((len (length (caar lst))))
- (if (< len 6)
- (write (caar lst) port)
- (let ((p (caar lst)))
- (write-char #\( port)
- (do ((i 0 (+ i 6)))
- ((>= i len))
- (do ((j 0 (+ j 1)))
- ((or (= j 6)
- (null? p))
- (if (pair? p) (spaces (+ column 4))))
- (write (car p) port)
- (set! p (cdr p))
- (if (pair? p) (write-char #\space port))))
- (write-char #\) port)))))
- (if (not (null? (cdar lst))) ; null here is a bug in the input case statement
- (if (and (pair? (cdar lst))
- (null? (cddar lst))
- (< (length (object->string (cadar lst))) 60))
- (begin
- (write-char #\space port)
- (write (cadar lst) port))
- (begin
- (spaces (+ column 3))
- (stacked-list (cdar lst) (+ column 3)))))
- (write-char #\) port))))
- (write-char #\) port))))
-
- ((begin call-with-exit call/cc call-with-current-continuation with-baffle with-output-to-string call-with-output-string)
- (format port "(~A" (car obj))
- (if (pair? (cdr obj))
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
- (write-char #\) port))
-
- ((map for-each)
- (let* ((objstr (object->string obj))
- (strlen (length objstr)))
- (if (< (+ column strlen) *pretty-print-length*)
- (display objstr port)
- (begin
- (format port "(~A" (car obj))
- (if (pair? (cdr obj))
- (begin
- (write-char #\space port)
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
- (write-char #\) port)))))
-
- ((dynamic-wind call-with-values)
- (format port "(~A" (car obj))
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))
-
- ((if)
- (let ((objstr (object->string obj))
- (ifcol (+ column 4)))
- (if (< (length objstr) 40)
- (display objstr port)
- (begin
- (format port "(if ")
- (pretty-print-1 (cadr obj) port ifcol)
- (when (pair? (cddr obj)) ; might be a messed-up if
- (spaces ifcol)
- (pretty-print-1 (caddr obj) port ifcol)
- (when (pair? (cdddr obj))
- (spaces ifcol)
- (pretty-print-1 (cadddr obj) port ifcol)))
- (write-char #\) port)))))
-
- ((when unless)
- (let ((objstr (object->string obj)))
- (if (< (length objstr) 40)
- (display objstr port)
- (begin
- (format port "(~A " (car obj))
- (pretty-print-1 (cadr obj) port (+ column (if (eq? (car obj) 'when) 6 8)))
- (spaces (+ column *pretty-print-spacing*))
- (when (pair? (cddr obj))
- (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
- (write-char #\) port)))))
-
- ((let let* letrec letrec*)
- (if (not (and (pair? (cdr obj))
- (pair? (cddr obj))))
- (write obj port)
- (begin
- (let ((head-len (length (symbol->string (car obj)))))
- (if (symbol? (cadr obj))
- (begin
- (format port "(~A ~A (" (car obj) (cadr obj))
- (if (pair? (cddr obj))
- (if (pair? (caddr obj)) ; (let x () ...)
- (stacked-split-list (caddr obj) (+ column head-len (length (symbol->string (cadr obj))) 4))
- (if (not (null? (caddr obj)))
- (write (caddr obj) port))) ; () is already being written
- (if (not (null? (cddr obj)))
- (format port " . ~S" (cddr obj)))))
- (begin
- (format port "(~A (" (car obj))
- (if (pair? (cadr obj))
- (stacked-split-list (cadr obj) (+ column head-len 3))))))
- (write-char #\) port)
- (spaces (+ column *pretty-print-spacing*))
- (if (pair? ((if (symbol? (cadr obj)) cdddr cddr) obj))
- (stacked-list ((if (symbol? (cadr obj)) cdddr cddr) obj) (+ column *pretty-print-spacing*)))
- (write-char #\) port))))
-
- ((inlet)
- (format port "(inlet ")
- (if (pair? (cdr obj))
- (do ((lst (cdr obj) (cddr lst)))
- ((not (and (pair? lst)
- (pair? (cdr lst)))))
- (if (not (eq? lst (cdr obj)))
- (spaces (+ column *pretty-print-spacing*)))
- (if (pair? (cdr lst))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*))))
+ (write-char #\) port)))))
+
+ ((dynamic-wind call-with-values)
+ (format port "(~A" (car obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))
+
+ ((if)
+ (let ((objstr (object->string obj))
+ (ifcol (+ column 4)))
+ (if (< (length objstr) 40)
+ (display objstr port)
+ (begin
+ (format port "(if ")
+ (pretty-print-1 (cadr obj) port ifcol)
+ (when (pair? (cddr obj)) ; might be a messed-up if
+ (spaces ifcol)
+ (pretty-print-1 (caddr obj) port ifcol)
+ (when (pair? (cdddr obj))
+ (spaces ifcol)
+ (pretty-print-1 (cadddr obj) port ifcol)))
+ (write-char #\) port)))))
+
+ ((when unless)
+ (let ((objstr (object->string obj)))
+ (if (< (length objstr) 40)
+ (display objstr port)
(begin
- (write (car lst) port)
- (write-char #\space port)
- (pretty-print-1 (cadr lst) port (+ column *pretty-print-spacing* (length (object->string (car lst))))))
- (write lst port))))
- (write-char #\) port))
-
- ((set!)
- (let ((str (object->string obj)))
- (if (<= (length str) 60)
- (display str port)
- (let ((settee (object->string (cadr obj))))
- (format port "(set! ~A" settee)
- (if (> (length settee) 20)
- (begin
- (spaces (+ column 6))
- (pretty-print-1 (caddr obj) port (+ column 6)))
- (begin
- (write-char #\space port)
- (pretty-print-1 (caddr obj) port (+ column 7 (length settee)))))
- (write-char #\) port)))))
-
- ((quote)
- (if (not (pair? (cdr obj))) ; (quote) or (quote . 1)
- (write obj port)
- (begin
- (write-char #\' port)
- (pretty-print-1 (cadr obj) port column))))
-
- ((catch)
- (format port "(~A ~S" catch (cadr obj))
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
- (write-char #\) port))
-
- (else
- (let* ((objstr (object->string obj))
- (strlen (length objstr)))
- (if (< (+ column strlen) *pretty-print-length*)
- (display objstr port)
- (let ((lstlen (length obj)))
- (if (or (infinite? lstlen)
- (< lstlen 2))
- (display objstr port)
- (if (and (pair? (car obj))
- (memq (caar obj) '(lambda lambda* let let* letrec letrec*)))
+ (format port "(~A " (car obj))
+ (pretty-print-1 (cadr obj) port (+ column (if (eq? (car obj) 'when) 6 8)))
+ (spaces (+ column *pretty-print-spacing*))
+ (when (pair? (cddr obj))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*)))
+ (write-char #\) port)))))
+
+ ((let let* letrec letrec*)
+ (if (not (and (pair? (cdr obj))
+ (pair? (cddr obj))))
+ (write obj port)
+ (begin
+ (let ((head-len (length (symbol->string (car obj)))))
+ (if (symbol? (cadr obj))
(begin
- (write-char #\( port)
- (pretty-print-1 (car obj) port column)
- (spaces (+ column 1))
- (stacked-list (cdr obj) (+ column 1)) ; the args?
- (write-char #\) port))
- (let* ((carstr (object->string (car obj)))
- (carstrlen (length carstr)))
- (if (eq? (car obj) 'quote)
- (write-char #\' port)
- (format port "(~A" carstr))
- (if (any-keyword? (cdr obj))
- (begin
- (spaces (+ column *pretty-print-spacing*))
- (stacked-list (cdr obj) (+ column *pretty-print-spacing*)))
- (let ((line-start (+ column *pretty-print-spacing*
- (if (or (> carstrlen 16)
- (pair? (cadr obj)))
- 0
- carstrlen))))
- (if (= lstlen 2)
- (begin
- (write-char #\space port)
- (pretty-print-1 (cadr obj) port line-start))
- (if (< lstlen 4)
+ (format port "(~A ~A (" (car obj) (cadr obj))
+ (if (pair? (cddr obj))
+ (if (pair? (caddr obj)) ; (let x () ...)
+ (stacked-split-list (caddr obj) (+ column head-len (length (symbol->string (cadr obj))) 4))
+ (if (not (null? (caddr obj)))
+ (write (caddr obj) port))) ; () is already being written
+ (if (not (null? (cddr obj)))
+ (format port " . ~S" (cddr obj)))))
+ (begin
+ (format port "(~A (" (car obj))
+ (if (pair? (cadr obj))
+ (stacked-split-list (cadr obj) (+ column head-len 3))))))
+ (write-char #\) port)
+ (spaces (+ column *pretty-print-spacing*))
+ (if (pair? ((if (symbol? (cadr obj)) cdddr cddr) obj))
+ (stacked-list ((if (symbol? (cadr obj)) cdddr cddr) obj) (+ column *pretty-print-spacing*)))
+ (write-char #\) port))))
+
+ ((inlet)
+ (format port "(inlet ")
+ (if (pair? (cdr obj))
+ (do ((lst (cdr obj) (cddr lst)))
+ ((not (and (pair? lst)
+ (pair? (cdr lst)))))
+ (if (not (eq? lst (cdr obj)))
+ (spaces (+ column *pretty-print-spacing*)))
+ (if (pair? (cdr lst))
+ (begin
+ (write (car lst) port)
+ (write-char #\space port)
+ (pretty-print-1 (cadr lst) port (+ column *pretty-print-spacing* (length (object->string (car lst))))))
+ (write lst port))))
+ (write-char #\) port))
+
+ ((set!)
+ (let ((str (object->string obj)))
+ (if (<= (length str) 60)
+ (display str port)
+ (let ((settee (object->string (cadr obj))))
+ (format port "(set! ~A" settee)
+ (if (> (length settee) 20)
+ (begin
+ (spaces (+ column 6))
+ (pretty-print-1 (caddr obj) port (+ column 6)))
+ (begin
+ (write-char #\space port)
+ (pretty-print-1 (caddr obj) port (+ column 7 (length settee)))))
+ (write-char #\) port)))))
+
+ ((quote)
+ (if (not (pair? (cdr obj))) ; (quote) or (quote . 1)
+ (write obj port)
+ (begin
+ (write-char #\' port)
+ (pretty-print-1 (cadr obj) port column))))
+
+ ((catch)
+ (format port "(~A ~S" catch (cadr obj))
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cddr obj) (+ column *pretty-print-spacing*))
+ (write-char #\) port))
+
+ (else
+ (let* ((objstr (object->string obj))
+ (strlen (length objstr)))
+ (if (< (+ column strlen) *pretty-print-length*)
+ (display objstr port)
+ (let ((lstlen (length obj)))
+ (if (or (infinite? lstlen)
+ (< lstlen 2))
+ (display objstr port)
+ (if (and (pair? (car obj))
+ (memq (caar obj) '(lambda lambda* let let* letrec letrec* cond if case)))
+ (begin
+ (write-char #\( port)
+ (pretty-print-1 (car obj) port column)
+ (spaces (+ column 1))
+ (if (and (memq (caar obj) '(cond if case))
+ (do ((p (cdr obj) (cdr p)))
+ ((or (null? p)
+ (pair? (car p)))
+ (null? p))))
+ (do ((p (cdr obj) (cdr p)))
+ ((null? p))
+ (display (car p) port)
+ (if (pair? (cdr p))
+ (write-char #\space port)))
+ (stacked-list (cdr obj) (+ column 1)))
+ (write-char #\) port))
+ (let* ((carstr (object->string (car obj)))
+ (carstrlen (length carstr)))
+ (if (eq? (car obj) 'quote)
+ (write-char #\' port)
+ (format port "(~A" carstr))
+ (if (any-keyword? (cdr obj))
+ (begin
+ (spaces (+ column *pretty-print-spacing*))
+ (stacked-list (cdr obj) (+ column *pretty-print-spacing*)))
+ (let ((line-start (+ column *pretty-print-spacing*
+ (if (or (> carstrlen 16)
+ (pair? (cadr obj)))
+ 0
+ carstrlen))))
+ (if (= lstlen 2)
(begin
(write-char #\space port)
- (stacked-list (cdr obj) line-start))
- (let ((obj-start line-start))
- (do ((lst (cdr obj) (cdr lst)))
- ((null? lst))
- (let* ((str (format #f "~S" (car lst)))
- (strlen1 (length str)))
- (if (and (> strlen1 (- *pretty-print-length* obj-start))
- (not (eq? lst (cdr obj))))
- (begin
- (set! obj-start (+ line-start 1 strlen1))
- (spaces line-start)
- (pretty-print-1 (car lst) port line-start))
- (begin
- (set! obj-start (+ obj-start 1 strlen1))
- (if (> strlen1 40)
- (begin
- (spaces line-start)
- (pretty-print-1 (car lst) port line-start))
- (begin
- (write-char #\space port)
- (display str port))))))))))))
- (if (not (eq? (car obj) 'quote))
- (write-char #\) port)))))))))))
- (else
- (write obj port))))
+ (pretty-print-1 (cadr obj) port line-start))
+ (if (< lstlen 4)
+ (begin
+ (write-char #\space port)
+ (stacked-list (cdr obj) line-start))
+ (let ((obj-start line-start))
+ (do ((lst (cdr obj) (cdr lst)))
+ ((null? lst))
+ (let* ((str (format #f "~S" (car lst)))
+ (strlen1 (length str)))
+ (if (and (> strlen1 (- *pretty-print-length* obj-start))
+ (not (eq? lst (cdr obj))))
+ (begin
+ (set! obj-start (+ line-start 1 strlen1))
+ (spaces line-start)
+ (pretty-print-1 (car lst) port line-start))
+ (begin
+ (set! obj-start (+ obj-start 1 strlen1))
+ (if (> strlen1 40)
+ (begin
+ (spaces line-start)
+ (pretty-print-1 (car lst) port line-start))
+ (begin
+ (write-char #\space port)
+ (display str port))))))))))))
+ (if (not (eq? (car obj) 'quote))
+ (write-char #\) port)))))))))))
+ (else
+ (write obj port))))))
(let ((old-port port))
(if (boolean? old-port)
diff --git a/ws.scm b/ws.scm
index 0b5e3c5..9b8f6b9 100644
--- a/ws.scm
+++ b/ws.scm
@@ -293,9 +293,7 @@
(if (and play output-to-file)
(if to-snd
- (if *clm-player*
- (*clm-player* snd-output)
- (*default-player* snd-output))
+ ((or *clm-player* *default-player*) snd-output)
(*default-player* output-1)))
(if (and to-snd output-to-file)
@@ -698,25 +696,17 @@
(define ws-save-state
(let ((documentation "(ws-save-state filename) is an after-save-state-hook function that saves the current with-sound global settings"))
(lambda (hook)
- (let ((filename (hook 'name)))
-
- (define (open-appending filename)
- (open-output-file filename "a"))
-
- (define close-appending close-output-port)
-
- (let ((fd (open-appending filename)))
- ;; fd is a Scheme port at this point (not an integer), so we can use format etc
- ;; should the save-state file load this file if it hasn't been loaded? (what path?)
- (format fd "~%~%;;; from ws.scm~%")
- (format fd "(if (defined? '*clm-srate*)~%")
- (format fd " (begin~%")
- (format fd " (set! *clm-srate* ~A)~%" *clm-srate*)
- (format fd " (set! *clm-file-name* ~S)~%" *clm-file-name*)
- (format fd " (set! *clm-channels* ~A)~%" *clm-channels*)
- (format fd " (set! *clm-sample-type* ~A)~%" (mus-sample-type->string *clm-sample-type*))
- (format fd " (set! *clm-header-type* ~A)))~%" (mus-header-type->string *clm-header-type*))
- (close-appending fd))))))
+ (let ((fd (open-output-file (hook 'name) "a")))
+ ;; should the save-state file load this file if it hasn't been loaded? (what path?)
+ (format fd "~%~%;;; from ws.scm~%")
+ (format fd "(if (defined? '*clm-srate*)~%")
+ (format fd " (begin~%")
+ (format fd " (set! *clm-srate* ~A)~%" *clm-srate*)
+ (format fd " (set! *clm-file-name* ~S)~%" *clm-file-name*)
+ (format fd " (set! *clm-channels* ~A)~%" *clm-channels*)
+ (format fd " (set! *clm-sample-type* ~A)~%" (mus-sample-type->string *clm-sample-type*))
+ (format fd " (set! *clm-header-type* ~A)))~%" (mus-header-type->string *clm-header-type*))
+ (close-output-port fd)))))
(if (not (memq ws-save-state (hook-functions after-save-state-hook)))
(set! (hook-functions after-save-state-hook) (list ws-save-state)))
@@ -745,7 +735,7 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(and (> (length name) 2)
(char-numeric? (name 2))
(name 2))))
- (base (modulo (+ 5 (- (char->integer base-char) (char->integer #\a))) 7)) ; c-based (diatonic) octaves
+ (base (modulo (- (+ (char->integer base-char) 5) (char->integer #\a)) 7)) ; c-based (diatonic) octaves
(sign (if (not sign-char) 0 (if (char=? sign-char #\f) -1 1)))
(octave (if octave-char (- (char->integer octave-char) (char->integer #\0)) last-octave))
(base-pitch (+ sign (case base ((0) 0) ((1) 2) ((2) 4) ((3) 5) ((4) 7) ((5) 9) ((6) 11))))
@@ -773,8 +763,7 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(define-macro (defgenerator struct-name . fields)
(define (list->bindings lst)
- (let* ((len (length lst))
- (nlst (make-list (* len 2))))
+ (let ((nlst (make-list (* (length lst) 2))))
(do ((old lst (cdr old))
(nsym nlst (cddr nsym)))
((null? old) nlst)
@@ -808,18 +797,18 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(eq? (struct-name 3) :methods)
(struct-name 4))))))
`(begin
- (define ,(string->symbol (string-append sname "?")) #f)
- (define ,(string->symbol (string-append "make-" sname)) #f)
+ (define ,(symbol sname "?") #f)
+ (define ,(symbol "make-" sname) #f)
- (let ((gen-type ',(string->symbol (string-append "+" sname "+")))
+ (let ((gen-type ',(symbol "+" sname "+"))
(gen-methods (and ,methods (apply inlet ,methods))))
- (set! ,(string->symbol (string-append sname "?"))
+ (set! ,(symbol sname "?")
(lambda (obj)
(and (let? obj)
(eq? (obj 'mus-generator-type) gen-type))))
- (set! ,(string->symbol (string-append "make-" sname))
+ (set! ,(symbol "make-" sname)
(lambda* ,(map (lambda (n)
(if (pair? n) n (list n 0.0)))
fields)
diff --git a/xen.c b/xen.c
index 1b001f3..f8f3f23 100644
--- a/xen.c
+++ b/xen.c
@@ -1725,8 +1725,10 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc)
(else (loop (cdr l) (cons (car l) result)))))))");
Xen_eval_C_string("(define load-from-path load)");
+#if (!DISABLE_DEPRECATED)
Xen_eval_C_string("(define (1+ x) \"add 1 to arg\" (+ x 1))");
Xen_eval_C_string("(define (1- x) \"subtract 1 from arg\" (- x 1))");
+#endif
Xen_eval_C_string("(define-macro (while whether . body) `(do () ((not ,whether)) , at body))");
Xen_eval_C_string("(define (identity x) \"return arg\" x)");
diff --git a/xg.c b/xg.c
index b2ee3c4..c1b2b69 100644
--- a/xg.c
+++ b/xg.c
@@ -200,7 +200,7 @@ static void define_xm_obj(void)
#define Xg_field_pre "F"
#endif
-static Xen xg_GdkDeviceTool__symbol, xg_GdkAxisFlags_symbol, xg_GtkTextLayout__symbol, xg_GdkRectangle_symbol, xg_prepare_func_symbol, xg_event_symbol, xg_const_symbol, xg_GdkSeatCapabilities_symbol, xg_GdkGrabStatus_symbol, xg_GtkPopoverConstraint_symbol, xg_GtkAllocation_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSidebar__symbol, xg_GtkSearchEntry__symbol, xg_GtkPopoverMenu__symbol, xg_GtkStyleContext__symbol, xg_GdkGLContext__symbol, xg_GtkGLArea__symbol, xg_GtkPropagationPhase_symbol, xg_GtkEventController__symbol, xg_GtkGestureZoom__symbol, xg_GtkGestureSwipe__symbol, xg_GtkGestureSingle__symbol, xg_GtkGestureRotate__symbol, xg_GtkGestureMultiPress__symbol, xg_GtkGesturePan__symbol, xg_GtkGestureDrag__symbol, xg_GdkEventSequence__symbol, xg_GtkEventSequenceState_symbol, xg_GtkGesture__symbol, xg_GtkPopover__symbol, xg_GtkActionBar__symbol, xg_GtkFlowBox__symbol, xg_GtkFlowBoxChild__symbol, xg_GdkEventType_symbol, xg_GtkSearchBar__symbol, xg_GtkListBox__symbol, xg_GtkListBoxRow__symbol, xg_GtkHeaderBar__symbol, xg_GtkRevealerTransitionType_symbol, xg_GtkRevealer__symbol, xg_GtkStackTransitionType_symbol, xg_GtkStack__symbol, xg_GtkStackSwitcher__symbol, xg_GtkPlacesSidebar__symbol, xg_GtkPlacesOpenFlags_symbol, xg_GtkBaselinePosition_symbol, xg_GdkFullscreenMode_symbol, xg_GtkInputHints_symbol, xg_GtkInputPurpose_symbol, xg_GtkLevelBarMode_symbol, xg_GtkLevelBar__symbol, xg_GtkMenuButton__symbol, xg_GtkColorChooser__symbol, xg_GtkApplicationWindow__symbol, xg_GtkApplication__symbol, xg_GMenuModel__symbol, xg_guint___symbol, xg_GdkModifierIntent_symbol, xg_GtkFontChooser__symbol, xg_GdkScrollDirection_symbol, xg_GtkOverlay__symbol, xg_GtkWidgetPath__symbol, xg_GtkStateFlags_symbol, xg_GdkScreen___symbol, xg_GtkToolShell__symbol, xg_GtkWindowGroup__symbol, xg_GtkInvisible__symbol, xg_GtkOrientable__symbol, xg_GtkCellArea__symbol, xg_GtkBorder__symbol, xg_GtkSwitch__symbol, xg_GtkScrollablePolicy_symbol, xg_GtkScrollable__symbol, xg_GtkGrid__symbol, xg_GdkRGBA__symbol, xg_GtkComboBoxText__symbol, xg_GtkAlign_symbol, xg_GtkContainerClass__symbol, xg_GtkSizeRequestMode_symbol, xg_cairo_region_overlap_t_symbol, xg_cairo_rectangle_int_t__symbol, xg_double__symbol, xg_cairo_rectangle_t__symbol, xg_cairo_device_t__symbol, xg_cairo_bool_t_symbol, xg_cairo_text_cluster_flags_t__symbol, xg_cairo_text_cluster_t___symbol, xg_cairo_glyph_t___symbol, xg_cairo_text_cluster_flags_t_symbol, xg_cairo_text_cluster_t__symbol, xg_cairo_region_t__symbol, xg_GtkMessageDialog__symbol, xg_GdkDevice__symbol, xg_GtkAccessible__symbol, xg_GdkModifierType__symbol, xg_GtkToolPaletteDragTargets_symbol, xg_GtkToolItemGroup__symbol, xg_GtkToolPalette__symbol, xg_GtkSpinner__symbol, xg_GtkEntryBuffer__symbol, xg_GtkMessageType_symbol, xg_GtkInfoBar__symbol, xg_GIcon__symbol, xg_GtkEntryIconPosition_symbol, xg_GFile__symbol, xg_GtkScaleButton__symbol, xg_GtkCalendarDetailFunc_symbol, xg_GtkTooltip__symbol, xg_cairo_rectangle_list_t__symbol, xg_void__symbol, xg_cairo_filter_t_symbol, xg_cairo_extend_t_symbol, xg_cairo_format_t_symbol, xg_cairo_path_t__symbol, xg_cairo_destroy_func_t_symbol, xg_cairo_user_data_key_t__symbol, xg_cairo_text_extents_t__symbol, xg_cairo_font_extents_t__symbol, xg_cairo_font_face_t__symbol, xg_cairo_glyph_t__symbol, xg_cairo_scaled_font_t__symbol, xg_cairo_font_weight_t_symbol, xg_cairo_font_slant_t_symbol, xg_cairo_hint_metrics_t_symbol, xg_cairo_hint_style_t_symbol, xg_cairo_subpixel_order_t_symbol, xg_cairo_status_t_symbol, xg_bool_symbol, xg_cairo_matrix_t__symbol, xg_cairo_line_join_t_symbol, xg_cairo_line_cap_t_symbol, xg_cairo_fill_rule_t_symbol, xg_cairo_antialias_t_symbol, xg_cairo_operator_t_symbol, xg_cairo_pattern_t__symbol, xg_cairo_content_t_symbol, xg_GtkPageSet_symbol, xg_GtkPageRange__symbol, xg_GtkPrintPages_symbol, xg_GtkPrintQuality_symbol, xg_GtkPrintDuplex_symbol, xg_GtkPaperSize__symbol, xg_GtkPageOrientation_symbol, xg_GtkPrintSettingsFunc_symbol, xg_GtkPrintOperationPreview__symbol, xg_GtkPageSetupDoneFunc_symbol, xg_GtkPrintStatus_symbol, xg_GtkPrintOperationAction_symbol, xg_GtkPrintOperationResult_symbol, xg_GtkUnit_symbol, xg_GtkPrintSettings__symbol, xg_GtkPrintOperation__symbol, xg_GtkPageSetup__symbol, xg_GtkPrintContext__symbol, xg_cairo_surface_t__symbol, xg_GtkTreeViewGridLines_symbol, xg_GtkRecentData__symbol, xg_GtkTextBufferDeserializeFunc_symbol, xg_GtkTextBufferSerializeFunc_symbol, xg_time_t_symbol, xg_GtkRecentChooserMenu__symbol, xg_GtkRecentManager__symbol, xg_GtkRecentFilter__symbol, xg_GtkRecentSortFunc_symbol, xg_GtkRecentSortType_symbol, xg_GtkRecentChooser__symbol, xg_GtkLinkButton__symbol, xg_GtkAssistantPageType_symbol, xg_GtkAssistantPageFunc_symbol, xg_GtkAssistant__symbol, xg_GDestroyNotify_symbol, xg_GtkTreeViewSearchPositionFunc_symbol, xg_GtkSensitivityType_symbol, xg_GtkClipboardRichTextReceivedFunc_symbol, xg_GtkMenuBar__symbol, xg_GtkPackDirection_symbol, xg_GtkIconViewDropPosition_symbol, xg_GValue__symbol, xg_GLogFunc_symbol, xg_PangoMatrix__symbol, xg_PangoRenderPart_symbol, xg_PangoRenderer__symbol, xg_GtkClipboardImageReceivedFunc_symbol, xg_GtkMenuToolButton__symbol, xg_GtkFileChooserButton__symbol, xg_PangoScriptIter__symbol, xg_PangoScript_symbol, xg_PangoAttrFilterFunc_symbol, xg_PangoEllipsizeMode_symbol, xg_GtkIconViewForeachFunc_symbol, xg_GtkAboutDialog__symbol, xg_GtkTreeViewRowSeparatorFunc_symbol, xg_GtkCellView__symbol, xg_GtkAccelMap__symbol, xg_GtkClipboardTargetsReceivedFunc_symbol, xg_GtkOrientation_symbol, xg_GtkToolButton__symbol, xg_GtkIconLookupFlags_symbol, xg_GtkIconInfo__symbol, xg_GtkIconTheme__symbol, xg_GtkFileChooser__symbol, xg_GtkCellLayoutDataFunc_symbol, xg_GtkCellLayout__symbol, xg_GtkFileFilterFunc_symbol, xg_GtkFileFilterFlags_symbol, xg_GtkFileFilter__symbol, xg_GSourceFunc_symbol, xg_GtkToggleToolButton__symbol, xg_GtkSeparatorToolItem__symbol, xg_GtkRadioToolButton__symbol, xg_GtkEntryCompletionMatchFunc_symbol, xg_GtkFontButton__symbol, xg_GtkExpander__symbol, xg_GtkComboBox__symbol, xg_GtkTreeModelFilter__symbol, xg_GtkFileChooserAction_symbol, xg_GtkToolItem__symbol, xg_GtkEventBox__symbol, xg_GtkCalendarDisplayOptions_symbol, xg_GdkScreen__symbol, xg_PangoLayoutRun__symbol, xg_PangoLayoutIter__symbol, xg_PangoLayoutLine__symbol, xg_int__symbol, xg_PangoAlignment_symbol, xg_PangoWrapMode_symbol, xg_PangoItem__symbol, xg_PangoGlyphString__symbol, xg_PangoFontMap__symbol, xg_PangoGlyph_symbol, xg_PangoFontFace__symbol, xg_PangoFontFace___symbol, xg_PangoFontFamily__symbol, xg_PangoFontMask_symbol, xg_PangoFontDescription___symbol, xg_PangoCoverageLevel_symbol, xg_PangoCoverage__symbol, xg_PangoFontMetrics__symbol, xg_PangoFontset__symbol, xg_PangoFont__symbol, xg_PangoFontFamily___symbol, xg_PangoLogAttr__symbol, xg_PangoAnalysis__symbol, xg_PangoAttrList___symbol, xg_PangoAttrIterator__symbol, xg_PangoRectangle__symbol, xg_PangoUnderline_symbol, xg_PangoStretch_symbol, xg_PangoVariant_symbol, xg_PangoWeight_symbol, xg_PangoStyle_symbol, xg_guint16_symbol, xg_PangoAttribute__symbol, xg_PangoAttrType_symbol, xg_PangoColor__symbol, xg_GdkGravity_symbol, xg_GtkWindowPosition_symbol, xg_GtkWindowType_symbol, xg_GtkWindow__symbol, xg_GtkTextDirection_symbol, xg_AtkObject__symbol, xg_GtkDirectionType_symbol, xg_GtkAllocation__symbol, xg_GtkViewport__symbol, xg_GtkTreeViewSearchEqualFunc_symbol, xg_GtkTreeViewDropPosition_symbol, xg_GtkTreeViewMappingFunc_symbol, xg_GtkTreeViewColumnDropFunc_symbol, xg_GtkTreeViewColumnSizing_symbol, xg_GtkTreeCellDataFunc_symbol, xg_GtkTreeStore__symbol, xg_GtkTreeIterCompareFunc_symbol, xg_GtkSortType_symbol, xg_GtkTreeSortable__symbol, xg_GtkTreeSelectionForeachFunc_symbol, xg_GtkTreeModel___symbol, xg_GtkTreeSelectionFunc_symbol, xg_GtkSelectionMode_symbol, xg_GtkTreeModelSort__symbol, xg_GtkTreeModelForeachFunc_symbol, xg_GtkTreeModelFlags_symbol, xg_GtkTreeRowReference__symbol, xg_GtkTreeDragDest__symbol, xg_GtkTreeDragSource__symbol, xg_GtkToolbarStyle_symbol, xg_GtkToolbar__symbol, xg_GtkToggleButton__symbol, xg_PangoTabArray__symbol, xg_GtkWrapMode_symbol, xg_GtkTextWindowType_symbol, xg_GtkTextView__symbol, xg_GtkTextTagTableForeach_symbol, xg_GtkTextSearchFlags_symbol, xg_GtkTextCharPredicate_symbol, xg_GtkTextAttributes__symbol, xg_GtkTextMark__symbol, xg_GtkTextChildAnchor__symbol, xg_GtkTextIter__symbol, xg_GtkTextTagTable__symbol, xg_GtkTextBuffer__symbol, xg_GtkStatusbar__symbol, xg_GtkSpinType_symbol, xg_GtkSpinButtonUpdatePolicy_symbol, xg_GtkSpinButton__symbol, xg_GtkSizeGroupMode_symbol, xg_GtkSizeGroup__symbol, xg_GtkSettings__symbol, xg_GtkCornerType_symbol, xg_GtkPolicyType_symbol, xg_GtkScrolledWindow__symbol, xg_GtkScale__symbol, xg_GtkRange__symbol, xg_GtkRadioMenuItem__symbol, xg_GtkRadioButton__symbol, xg_GtkProgressBar__symbol, xg_GtkPaned__symbol, xg_GtkPositionType_symbol, xg_GtkNotebook__symbol, xg_GtkMenuShell__symbol, xg_GtkMenuItem__symbol, xg_GtkMenuPositionFunc_symbol, xg_PangoLanguage__symbol, xg_GtkListStore__symbol, xg_GtkLayout__symbol, xg_GtkJustification_symbol, xg_GtkLabel__symbol, xg_guint16__symbol, xg_GtkIMContextSimple__symbol, xg_GdkEventKey__symbol, xg_PangoAttrList__symbol, xg_GtkIMContext__symbol, xg_GtkImageType_symbol, xg_GtkImage__symbol, xg_GtkShadowType_symbol, xg_GtkFrame__symbol, xg_GtkFixed__symbol, xg_PangoLayout__symbol, xg_GtkEntry__symbol, xg_GtkEditable__symbol, xg_GtkTargetList__symbol, xg_GtkDestDefaults_symbol, xg_etc_symbol, xg_GtkDialog__symbol, xg_GtkCallback_symbol, xg_GtkContainer__symbol, xg_GtkClipboardTextReceivedFunc_symbol, xg_GtkClipboardReceivedFunc_symbol, xg_GtkClipboardClearFunc_symbol, xg_GtkClipboardGetFunc_symbol, xg_GtkTargetEntry__symbol, xg_GtkCheckMenuItem__symbol, xg_GtkCellRendererToggle__symbol, xg_GtkCellRendererText__symbol, xg_GtkCellRendererState_symbol, xg_GtkCellEditable__symbol, xg_GtkCalendar__symbol, xg_GtkReliefStyle_symbol, xg_GtkButton__symbol, xg_GtkPackType_symbol, xg_GtkBox__symbol, xg_GtkBin__symbol, xg_GtkBindingSet__symbol, xg_GtkButtonBox__symbol, xg_GtkButtonBoxStyle_symbol, xg_GtkAspectFrame__symbol, xg_GtkAdjustment__symbol, xg_GtkAccelMapForeach_symbol, xg_GtkAccelLabel__symbol, xg_GtkAccelGroupEntry__symbol, xg_lambda3_symbol, xg_GSList__symbol, xg_GObject__symbol, xg_GtkAccelFlags_symbol, xg_GtkAccelGroup__symbol, xg_GTimeVal__symbol, xg_GdkPixbufAnimationIter__symbol, xg_GdkPixbufAnimation__symbol, xg_GdkInterpType_symbol, xg_double_symbol, xg_gfloat_symbol, xg_guchar_symbol, xg_char___symbol, xg_GdkPixbufDestroyNotify_symbol, xg_GError__symbol, xg_int_symbol, xg_GdkColorspace_symbol, xg_GdkWindowTypeHint_symbol, xg_GdkWindowHints_symbol, xg_GdkGeometry__symbol, xg_GdkWindowEdge_symbol, xg_GdkWMFunction_symbol, xg_GdkWMDecoration_symbol, xg_GdkEventMask_symbol, xg_GdkWindowState_symbol, xg_GdkFilterFunc_symbol, xg_GdkWindowType_symbol, xg_GdkWindowAttr__symbol, xg_GdkVisualType__symbol, xg_gint__symbol, xg_GdkVisualType_symbol, xg_GdkPropMode_symbol, xg_guchar__symbol, xg_PangoContext__symbol, xg_PangoDirection_symbol, xg_GdkKeymapKey__symbol, xg_GdkKeymap__symbol, xg_GdkRectangle__symbol, xg_char__symbol, xg_gchar___symbol, xg_GdkEventFunc_symbol, xg_gdouble_symbol, xg_GList__symbol, xg_guint32_symbol, xg_GdkDragAction_symbol, xg_GdkDragContext__symbol, xg_GdkCursorType_symbol, xg_GdkDisplay__symbol, xg_GdkCursor__symbol, xg_GdkVisual__symbol, xg_GSignalMatchType_symbol, xg_GConnectFlags_symbol, xg_GtkDestroyNotify_symbol, xg_GSignalEmissionHook_symbol, xg_gulong_symbol, xg_GSignalInvocationHint__symbol, xg_GQuark_symbol, xg_guint__symbol, xg_GSignalQuery__symbol, xg_GType__symbol, xg_GSignalCMarshaller_symbol, xg_gpointer_symbol, xg_GSignalAccumulator_symbol, xg_GSignalFlags_symbol, xg_GType_symbol, xg_GClosureNotify_symbol, xg_GCallback_symbol, xg_GNormalizeMode_symbol, xg_glong_symbol, xg_gssize_symbol, xg_gunichar__symbol, xg_void_symbol, xg_GdkWindow__symbol, xg_GdkSeat__symbol, xg_GtkRecentInfo__symbol, xg_gsize_symbol, xg_guint8__symbol, xg_GdkAtom_symbol, xg_GLogLevelFlags_symbol, xg_GdkPixbuf__symbol, xg_GtkIconView__symbol, xg_GtkEntryCompletion__symbol, xg_GtkFileFilterInfo__symbol, xg_GtkTreeSelection__symbol, xg_GtkCellRenderer__symbol, xg_GtkTreeViewColumn__symbol, xg_GtkTreeView__symbol, xg_gunichar_symbol, xg_GdkAtom__symbol, xg_GtkSelectionData__symbol, xg_GtkClipboard__symbol, xg_GtkTreeIter__symbol, xg_GtkTreePath__symbol, xg_GtkTreeModel__symbol, xg_GdkModifierType_symbol, xg_guint_symbol, xg_gchar__symbol, xg_GtkTextTag__symbol, xg_gboolean_symbol, xg_gint_symbol, xg_GtkMenu__symbol, xg_GdkXEvent__symbol, xg_GtkWidget__symbol, xg_lambda_data_symbol, xg_GClosure__symbol, xg_GtkAccelKey__symbol, xg_GdkEventMotion__symbol, xg_gdouble__symbol, xg_GdkEventAny__symbol, xg_GdkEvent__symbol, xg_cairo_t__symbol, xg_cairo_font_options_t__symbol, xg_PangoFontDescription__symbol, xg_idler_symbol, xg_GtkCellRendererPixbuf__symbol, xg_GtkCheckButton__symbol, xg_GtkDrawingArea__symbol, xg_GtkScrollbar__symbol, xg_GtkSeparator__symbol, xg_GtkSeparatorMenuItem__symbol, xg_GdkEventExpose__symbol, xg_GdkEventNoExpose__symbol, xg_GdkEventVisibility__symbol, xg_GdkEventButton__symbol, xg_GdkEventScroll__symbol, xg_GdkEventCrossing__symbol, xg_GdkEventFocus__symbol, xg_GdkEventConfigure__symbol, xg_GdkEventProperty__symbol, xg_GdkEventSelection__symbol, xg_GdkEventProximity__symbol, xg_GdkEventSetting__symbol, xg_GdkEventWindowState__symbol, xg_GdkEventDND__symbol, xg_GtkFileChooserDialog__symbol, xg_GtkFileChooserWidget__symbol, xg_GtkColorButton__symbol, xg_GtkAccelMap_symbol, xg_GtkCellRendererCombo__symbol, xg_GtkCellRendererProgress__symbol, xg_GtkCellRendererAccel__symbol, xg_GtkCellRendererSpin__symbol, xg_GtkRecentChooserDialog__symbol, xg_GtkRecentChooserWidget__symbol, xg_GtkCellRendererSpinner__symbol, xg_gboolean__symbol, xg_GtkFontChooserDialog__symbol, xg_GtkFontChooserWidget__symbol, xg_GtkColorChooserDialog__symbol, xg_GtkColorChooserWidget__symbol, xg_GtkColorWidget__symbol, xg_GtkGestureLongPress__symbol;
+static Xen xg_GdkSubpixelLayout_symbol, xg_menu_symbol, xg_gtk_menu_place_on_monitor_symbol, xg_GdkMonitor__symbol, xg_GdkDeviceTool__symbol, xg_GdkAxisFlags_symbol, xg_GdkSeatGrabPrepareFunc_symbol, xg_GdkSeatCapabilities_symbol, xg_GdkGrabStatus_symbol, xg_GtkPopoverConstraint_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSidebar__symbol, xg_GtkSearchEntry__symbol, xg_GtkPopoverMenu__symbol, xg_GtkStyleContext__symbol, xg_GdkGLContext__symbol, xg_GtkGLArea__symbol, xg_GtkPropagationPhase_symbol, xg_GtkEventController__symbol, xg_GtkGestureZoom__symbol, xg_GtkGestureSwipe__symbol, xg_GtkGestureSingle__symbol, xg_GtkGestureRotate__symbol, xg_GtkGestureMultiPress__symbol, xg_GtkGesturePan__symbol, xg_GtkGestureDrag__symbol, xg_GdkEventSequence__symbol, xg_GtkEventSequenceState_symbol, xg_GtkGesture__symbol, xg_GtkPopover__symbol, xg_GtkActionBar__symbol, xg_GtkFlowBox__symbol, xg_GtkFlowBoxChild__symbol, xg_GdkEventType_symbol, xg_GtkSearchBar__symbol, xg_GtkListBox__symbol, xg_GtkListBoxRow__symbol, xg_GtkHeaderBar__symbol, xg_GtkRevealerTransitionType_symbol, xg_GtkRevealer__symbol, xg_GtkStackTransitionType_symbol, xg_GtkStack__symbol, xg_GtkStackSwitcher__symbol, xg_GtkPlacesSidebar__symbol, xg_GtkPlacesOpenFlags_symbol, xg_GtkBaselinePosition_symbol, xg_GdkFullscreenMode_symbol, xg_GtkInputHints_symbol, xg_GtkInputPurpose_symbol, xg_GtkLevelBarMode_symbol, xg_GtkLevelBar__symbol, xg_GtkMenuButton__symbol, xg_GtkColorChooser__symbol, xg_GtkApplicationWindow__symbol, xg_GtkApplication__symbol, xg_GMenuModel__symbol, xg_guint___symbol, xg_GdkModifierIntent_symbol, xg_GtkFontChooser__symbol, xg_GdkScrollDirection_symbol, xg_GtkOverlay__symbol, xg_GtkWidgetPath__symbol, xg_GtkStateFlags_symbol, xg_GdkScreen___symbol, xg_GtkToolShell__symbol, xg_GtkWindowGroup__symbol, xg_GtkInvisible__symbol, xg_GtkOrientable__symbol, xg_GtkCellArea__symbol, xg_GtkBorder__symbol, xg_GtkSwitch__symbol, xg_GtkScrollablePolicy_symbol, xg_GtkScrollable__symbol, xg_GtkGrid__symbol, xg_GdkRGBA__symbol, xg_GtkComboBoxText__symbol, xg_GtkAlign_symbol, xg_GtkContainerClass__symbol, xg_GtkSizeRequestMode_symbol, xg_cairo_region_overlap_t_symbol, xg_cairo_rectangle_int_t__symbol, xg_double__symbol, xg_cairo_rectangle_t__symbol, xg_cairo_device_t__symbol, xg_cairo_bool_t_symbol, xg_cairo_text_cluster_flags_t__symbol, xg_cairo_text_cluster_t___symbol, xg_cairo_glyph_t___symbol, xg_cairo_text_cluster_flags_t_symbol, xg_cairo_text_cluster_t__symbol, xg_cairo_region_t__symbol, xg_GtkMessageDialog__symbol, xg_GdkDevice__symbol, xg_GtkAccessible__symbol, xg_GdkModifierType__symbol, xg_GtkToolPaletteDragTargets_symbol, xg_GtkToolItemGroup__symbol, xg_GtkToolPalette__symbol, xg_GtkSpinner__symbol, xg_GtkEntryBuffer__symbol, xg_GtkMessageType_symbol, xg_GtkInfoBar__symbol, xg_GIcon__symbol, xg_GtkEntryIconPosition_symbol, xg_GFile__symbol, xg_GtkScaleButton__symbol, xg_GtkCalendarDetailFunc_symbol, xg_GtkTooltip__symbol, xg_cairo_rectangle_list_t__symbol, xg_void__symbol, xg_cairo_filter_t_symbol, xg_cairo_extend_t_symbol, xg_cairo_format_t_symbol, xg_cairo_path_t__symbol, xg_cairo_destroy_func_t_symbol, xg_cairo_user_data_key_t__symbol, xg_cairo_text_extents_t__symbol, xg_cairo_font_extents_t__symbol, xg_cairo_font_face_t__symbol, xg_cairo_glyph_t__symbol, xg_cairo_scaled_font_t__symbol, xg_cairo_font_weight_t_symbol, xg_cairo_font_slant_t_symbol, xg_cairo_hint_metrics_t_symbol, xg_cairo_hint_style_t_symbol, xg_cairo_subpixel_order_t_symbol, xg_cairo_status_t_symbol, xg_bool_symbol, xg_cairo_matrix_t__symbol, xg_cairo_line_join_t_symbol, xg_cairo_line_cap_t_symbol, xg_cairo_fill_rule_t_symbol, xg_cairo_antialias_t_symbol, xg_cairo_operator_t_symbol, xg_cairo_pattern_t__symbol, xg_cairo_content_t_symbol, xg_GtkPageSet_symbol, xg_GtkPageRange__symbol, xg_GtkPrintPages_symbol, xg_GtkPrintQuality_symbol, xg_GtkPrintDuplex_symbol, xg_GtkPaperSize__symbol, xg_GtkPageOrientation_symbol, xg_GtkPrintSettingsFunc_symbol, xg_GtkPrintOperationPreview__symbol, xg_GtkPageSetupDoneFunc_symbol, xg_GtkPrintStatus_symbol, xg_GtkPrintOperationAction_symbol, xg_GtkPrintOperationResult_symbol, xg_GtkUnit_symbol, xg_GtkPrintSettings__symbol, xg_GtkPrintOperation__symbol, xg_GtkPageSetup__symbol, xg_GtkPrintContext__symbol, xg_cairo_surface_t__symbol, xg_GtkTreeViewGridLines_symbol, xg_GtkRecentData__symbol, xg_GtkTextBufferDeserializeFunc_symbol, xg_GtkTextBufferSerializeFunc_symbol, xg_time_t_symbol, xg_GtkRecentChooserMenu__symbol, xg_GtkRecentManager__symbol, xg_GtkRecentFilter__symbol, xg_GtkRecentSortFunc_symbol, xg_GtkRecentSortType_symbol, xg_GtkRecentChooser__symbol, xg_GtkLinkButton__symbol, xg_GtkAssistantPageType_symbol, xg_GtkAssistantPageFunc_symbol, xg_GtkAssistant__symbol, xg_GDestroyNotify_symbol, xg_GtkTreeViewSearchPositionFunc_symbol, xg_GtkSensitivityType_symbol, xg_GtkClipboardRichTextReceivedFunc_symbol, xg_GtkMenuBar__symbol, xg_GtkPackDirection_symbol, xg_GtkIconViewDropPosition_symbol, xg_GValue__symbol, xg_GLogFunc_symbol, xg_PangoMatrix__symbol, xg_PangoRenderPart_symbol, xg_PangoRenderer__symbol, xg_GtkClipboardImageReceivedFunc_symbol, xg_GtkMenuToolButton__symbol, xg_GtkFileChooserButton__symbol, xg_PangoScriptIter__symbol, xg_PangoScript_symbol, xg_PangoAttrFilterFunc_symbol, xg_PangoEllipsizeMode_symbol, xg_GtkIconViewForeachFunc_symbol, xg_GtkAboutDialog__symbol, xg_GtkTreeViewRowSeparatorFunc_symbol, xg_GtkCellView__symbol, xg_GtkAccelMap__symbol, xg_GtkClipboardTargetsReceivedFunc_symbol, xg_GtkOrientation_symbol, xg_GtkToolButton__symbol, xg_GtkIconLookupFlags_symbol, xg_GtkIconInfo__symbol, xg_GtkIconTheme__symbol, xg_GtkFileChooser__symbol, xg_GtkCellLayoutDataFunc_symbol, xg_GtkCellLayout__symbol, xg_GtkFileFilterFunc_symbol, xg_GtkFileFilterFlags_symbol, xg_GtkFileFilter__symbol, xg_GSourceFunc_symbol, xg_GtkToggleToolButton__symbol, xg_GtkSeparatorToolItem__symbol, xg_GtkRadioToolButton__symbol, xg_GtkEntryCompletionMatchFunc_symbol, xg_GtkFontButton__symbol, xg_GtkExpander__symbol, xg_GtkComboBox__symbol, xg_GtkTreeModelFilter__symbol, xg_GtkFileChooserAction_symbol, xg_GtkToolItem__symbol, xg_GtkEventBox__symbol, xg_GtkCalendarDisplayOptions_symbol, xg_GdkScreen__symbol, xg_PangoLayoutRun__symbol, xg_PangoLayoutIter__symbol, xg_PangoLayoutLine__symbol, xg_int__symbol, xg_PangoAlignment_symbol, xg_PangoWrapMode_symbol, xg_PangoItem__symbol, xg_PangoGlyphString__symbol, xg_PangoFontMap__symbol, xg_PangoGlyph_symbol, xg_PangoFontFace__symbol, xg_PangoFontFace___symbol, xg_PangoFontFamily__symbol, xg_PangoFontMask_symbol, xg_PangoFontDescription___symbol, xg_PangoCoverageLevel_symbol, xg_PangoCoverage__symbol, xg_PangoFontMetrics__symbol, xg_PangoFontset__symbol, xg_PangoFont__symbol, xg_PangoFontFamily___symbol, xg_PangoLogAttr__symbol, xg_PangoAnalysis__symbol, xg_PangoAttrList___symbol, xg_PangoAttrIterator__symbol, xg_PangoRectangle__symbol, xg_PangoUnderline_symbol, xg_PangoStretch_symbol, xg_PangoVariant_symbol, xg_PangoWeight_symbol, xg_PangoStyle_symbol, xg_guint16_symbol, xg_PangoAttribute__symbol, xg_PangoAttrType_symbol, xg_PangoColor__symbol, xg_GdkGravity_symbol, xg_GtkWindowPosition_symbol, xg_GtkWindowType_symbol, xg_GtkWindow__symbol, xg_GtkTextDirection_symbol, xg_AtkObject__symbol, xg_GtkDirectionType_symbol, xg_GtkAllocation__symbol, xg_GtkViewport__symbol, xg_GtkTreeViewSearchEqualFunc_symbol, xg_GtkTreeViewDropPosition_symbol, xg_GtkTreeViewMappingFunc_symbol, xg_GtkTreeViewColumnDropFunc_symbol, xg_GtkTreeViewColumnSizing_symbol, xg_GtkTreeCellDataFunc_symbol, xg_GtkTreeStore__symbol, xg_GtkTreeIterCompareFunc_symbol, xg_GtkSortType_symbol, xg_GtkTreeSortable__symbol, xg_GtkTreeSelectionForeachFunc_symbol, xg_GtkTreeModel___symbol, xg_GtkTreeSelectionFunc_symbol, xg_GtkSelectionMode_symbol, xg_GtkTreeModelSort__symbol, xg_GtkTreeModelForeachFunc_symbol, xg_GtkTreeModelFlags_symbol, xg_GtkTreeRowReference__symbol, xg_GtkTreeDragDest__symbol, xg_GtkTreeDragSource__symbol, xg_GtkToolbarStyle_symbol, xg_GtkToolbar__symbol, xg_GtkToggleButton__symbol, xg_PangoTabArray__symbol, xg_GtkWrapMode_symbol, xg_GtkTextWindowType_symbol, xg_GtkTextView__symbol, xg_GtkTextTagTableForeach_symbol, xg_GtkTextSearchFlags_symbol, xg_GtkTextCharPredicate_symbol, xg_GtkTextAttributes__symbol, xg_GtkTextMark__symbol, xg_GtkTextChildAnchor__symbol, xg_GtkTextIter__symbol, xg_GtkTextTagTable__symbol, xg_GtkTextBuffer__symbol, xg_GtkStatusbar__symbol, xg_GtkSpinType_symbol, xg_GtkSpinButtonUpdatePolicy_symbol, xg_GtkSpinButton__symbol, xg_GtkSizeGroupMode_symbol, xg_GtkSizeGroup__symbol, xg_GtkSettings__symbol, xg_GtkCornerType_symbol, xg_GtkPolicyType_symbol, xg_GtkScrolledWindow__symbol, xg_GtkScale__symbol, xg_GtkRange__symbol, xg_GtkRadioMenuItem__symbol, xg_GtkRadioButton__symbol, xg_GtkProgressBar__symbol, xg_GtkPaned__symbol, xg_GtkPositionType_symbol, xg_GtkNotebook__symbol, xg_GtkMenuShell__symbol, xg_GtkMenuItem__symbol, xg_GtkMenuPositionFunc_symbol, xg_PangoLanguage__symbol, xg_GtkListStore__symbol, xg_GtkLayout__symbol, xg_GtkJustification_symbol, xg_GtkLabel__symbol, xg_guint16__symbol, xg_GtkIMContextSimple__symbol, xg_GdkEventKey__symbol, xg_PangoAttrList__symbol, xg_GtkIMContext__symbol, xg_GtkImageType_symbol, xg_GtkImage__symbol, xg_GtkShadowType_symbol, xg_GtkFrame__symbol, xg_GtkFixed__symbol, xg_PangoLayout__symbol, xg_GtkEntry__symbol, xg_GtkEditable__symbol, xg_GtkTargetList__symbol, xg_GtkDestDefaults_symbol, xg_etc_symbol, xg_GtkDialog__symbol, xg_GtkCallback_symbol, xg_GtkContainer__symbol, xg_GtkClipboardTextReceivedFunc_symbol, xg_GtkClipboardReceivedFunc_symbol, xg_GtkClipboardClearFunc_symbol, xg_GtkClipboardGetFunc_symbol, xg_GtkTargetEntry__symbol, xg_GtkCheckMenuItem__symbol, xg_GtkCellRendererToggle__symbol, xg_GtkCellRendererText__symbol, xg_GtkCellRendererState_symbol, xg_GtkCellEditable__symbol, xg_GtkCalendar__symbol, xg_GtkReliefStyle_symbol, xg_GtkButton__symbol, xg_GtkPackType_symbol, xg_GtkBox__symbol, xg_GtkBin__symbol, xg_GtkBindingSet__symbol, xg_GtkButtonBox__symbol, xg_GtkButtonBoxStyle_symbol, xg_GtkAspectFrame__symbol, xg_GtkAdjustment__symbol, xg_GtkAccelMapForeach_symbol, xg_GtkAccelLabel__symbol, xg_GtkAccelGroupEntry__symbol, xg_lambda3_symbol, xg_GSList__symbol, xg_GObject__symbol, xg_GtkAccelFlags_symbol, xg_GtkAccelGroup__symbol, xg_GTimeVal__symbol, xg_GdkPixbufAnimationIter__symbol, xg_GdkPixbufAnimation__symbol, xg_GdkInterpType_symbol, xg_double_symbol, xg_gfloat_symbol, xg_guchar_symbol, xg_char___symbol, xg_GdkPixbufDestroyNotify_symbol, xg_GError__symbol, xg_int_symbol, xg_GdkColorspace_symbol, xg_GdkWindowTypeHint_symbol, xg_GdkWindowHints_symbol, xg_GdkGeometry__symbol, xg_GdkWindowEdge_symbol, xg_GdkWMFunction_symbol, xg_GdkWMDecoration_symbol, xg_GdkEventMask_symbol, xg_GdkWindowState_symbol, xg_GdkFilterFunc_symbol, xg_GdkWindowType_symbol, xg_GdkWindowAttr__symbol, xg_GdkVisualType__symbol, xg_gint__symbol, xg_GdkVisualType_symbol, xg_GdkPropMode_symbol, xg_guchar__symbol, xg_PangoContext__symbol, xg_PangoDirection_symbol, xg_GdkKeymapKey__symbol, xg_GdkKeymap__symbol, xg_GdkRectangle__symbol, xg_char__symbol, xg_gchar___symbol, xg_GdkEventFunc_symbol, xg_gdouble_symbol, xg_GList__symbol, xg_guint32_symbol, xg_GdkDragAction_symbol, xg_GdkDragContext__symbol, xg_GdkCursorType_symbol, xg_GdkDisplay__symbol, xg_GdkCursor__symbol, xg_GdkVisual__symbol, xg_GSignalMatchType_symbol, xg_GConnectFlags_symbol, xg_GtkDestroyNotify_symbol, xg_GSignalEmissionHook_symbol, xg_gulong_symbol, xg_GSignalInvocationHint__symbol, xg_GQuark_symbol, xg_guint__symbol, xg_GSignalQuery__symbol, xg_GType__symbol, xg_GSignalCMarshaller_symbol, xg_gpointer_symbol, xg_GSignalAccumulator_symbol, xg_GSignalFlags_symbol, xg_GType_symbol, xg_GClosureNotify_symbol, xg_GCallback_symbol, xg_GNormalizeMode_symbol, xg_glong_symbol, xg_gssize_symbol, xg_gunichar__symbol, xg_void_symbol, xg_GdkSeat__symbol, xg_GtkRecentInfo__symbol, xg_gsize_symbol, xg_guint8__symbol, xg_GdkAtom_symbol, xg_GLogLevelFlags_symbol, xg_GdkPixbuf__symbol, xg_GtkIconView__symbol, xg_GtkEntryCompletion__symbol, xg_GtkFileFilterInfo__symbol, xg_GtkTreeSelection__symbol, xg_GtkCellRenderer__symbol, xg_GtkTreeViewColumn__symbol, xg_GtkTreeView__symbol, xg_gunichar_symbol, xg_GdkAtom__symbol, xg_GtkSelectionData__symbol, xg_GtkClipboard__symbol, xg_GtkTreeIter__symbol, xg_GtkTreePath__symbol, xg_GtkTreeModel__symbol, xg_GdkModifierType_symbol, xg_guint_symbol, xg_gchar__symbol, xg_GtkTextTag__symbol, xg_gboolean_symbol, xg_gint_symbol, xg_GtkMenu__symbol, xg_GdkXEvent__symbol, xg_GtkWidget__symbol, xg_lambda_data_symbol, xg_GClosure__symbol, xg_GtkAccelKey__symbol, xg_GdkEventMotion__symbol, xg_gdouble__symbol, xg_GdkEventAny__symbol, xg_GdkEvent__symbol, xg_GdkWindow__symbol, xg_cairo_t__symbol, xg_cairo_font_options_t__symbol, xg_PangoFontDescription__symbol, xg_idler_symbol, xg_GtkCellRendererPixbuf__symbol, xg_GtkCheckButton__symbol, xg_GtkDrawingArea__symbol, xg_GtkScrollbar__symbol, xg_GtkSeparator__symbol, xg_GtkSeparatorMenuItem__symbol, xg_GdkEventExpose__symbol, xg_GdkEventNoExpose__symbol, xg_GdkEventVisibility__symbol, xg_GdkEventButton__symbol, xg_GdkEventScroll__symbol, xg_GdkEventCrossing__symbol, xg_GdkEventFocus__symbol, xg_GdkEventConfigure__symbol, xg_GdkEventProperty__symbol, xg_GdkEventSelection__symbol, xg_GdkEventProximity__symbol, xg_GdkEventSetting__symbol, xg_GdkEventWindowState__symbol, xg_GdkEventDND__symbol, xg_GtkFileChooserDialog__symbol, xg_GtkFileChooserWidget__symbol, xg_GtkColorButton__symbol, xg_GtkAccelMap_symbol, xg_GtkCellRendererCombo__symbol, xg_GtkCellRendererProgress__symbol, xg_GtkCellRendererAccel__symbol, xg_GtkCellRendererSpin__symbol, xg_GtkRecentChooserDialog__symbol, xg_GtkRecentChooserWidget__symbol, xg_GtkCellRendererSpinner__symbol, xg_gboolean__symbol, xg_GtkFontChooserDialog__symbol, xg_GtkFontChooserWidget__symbol, xg_GtkColorChooserDialog__symbol, xg_GtkColorChooserWidget__symbol, xg_GtkColorWidget__symbol, xg_GtkGestureLongPress__symbol;
#define wrap_for_Xen(Name, Value) Xen_list_2(xg_ ## Name ## _symbol, Xen_wrap_C_pointer(Value))
#define is_wrapped(Name, Value) (Xen_is_pair(Value) && (Xen_car(Value) == xg_ ## Name ## _symbol))
@@ -329,6 +329,7 @@ static Xen C_to_Xen_GError_(GError *err)
Xm_type_Ptr(PangoFontDescription_, PangoFontDescription*)
Xm_type_Ptr(cairo_font_options_t_, cairo_font_options_t*)
Xm_type_Ptr(cairo_t_, cairo_t*)
+Xm_type_Ptr(GdkWindow_, GdkWindow*)
Xm_type_Ptr_2(gboolean_, gboolean*)
Xm_type_Ptr(GdkEvent_, GdkEvent*)
Xm_type_Ptr_2(GdkEventAny_, GdkEventAny*)
@@ -444,7 +445,6 @@ Xm_type_Ptr(PangoContext_, PangoContext*)
#define Xen_is_guchar_(Arg) Xen_is_string(Arg)
#define Xen_to_C_GdkPropMode(Arg) (GdkPropMode)(Xen_integer_to_C_int(Arg))
#define Xen_is_GdkPropMode(Arg) Xen_is_integer(Arg)
-Xm_type_Ptr(GdkWindow_, GdkWindow*)
#define C_to_Xen_GdkVisualType(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_GdkVisualType(Arg) (GdkVisualType)(Xen_integer_to_C_int(Arg))
#define Xen_is_GdkVisualType(Arg) Xen_is_integer(Arg)
@@ -568,7 +568,7 @@ Xm_type_Ptr_1(GtkScrolledWindow_, GtkScrolledWindow*)
#define C_to_Xen_GtkCornerType(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_GtkCornerType(Arg) (GtkCornerType)(Xen_integer_to_C_int(Arg))
#define Xen_is_GtkCornerType(Arg) Xen_is_integer(Arg)
-Xm_type_Ptr_2(GtkSettings_, GtkSettings*)
+Xm_type_Ptr(GtkSettings_, GtkSettings*)
Xm_type_Ptr(GtkSizeGroup_, GtkSizeGroup*)
#define C_to_Xen_GtkSizeGroupMode(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_GtkSizeGroupMode(Arg) (GtkSizeGroupMode)(Xen_integer_to_C_int(Arg))
@@ -945,9 +945,7 @@ Xm_type_Ptr_1(GtkStackSidebar_, GtkStackSidebar*)
#if GTK_CHECK_VERSION(3, 20, 0)
Xm_type_Ptr(GdkSeat_, GdkSeat*)
-Xm_type_Ptr(GdkWindow_, GdkWindow*)
-Xm_type_Ptr(GtkShortcutsWindow_, GtkShortcutsWindow*)
-Xm_type(GtkAllocation, GtkAllocation)
+Xm_type_Ptr_1(GtkShortcutsWindow_, GtkShortcutsWindow*)
#define C_to_Xen_GtkPopoverConstraint(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_GtkPopoverConstraint(Arg) (GtkPopoverConstraint)(Xen_integer_to_C_int(Arg))
#define Xen_is_GtkPopoverConstraint(Arg) Xen_is_integer(Arg)
@@ -955,11 +953,6 @@ Xm_type(GtkAllocation, GtkAllocation)
#define C_to_Xen_GdkSeatCapabilities(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_GdkSeatCapabilities(Arg) (GdkSeatCapabilities)(Xen_integer_to_C_int(Arg))
#define Xen_is_GdkSeatCapabilities(Arg) Xen_is_integer(Arg)
-Xm_type(const, const)
-Xm_type(event, event)
-Xm_type(prepare_func, prepare_func)
-Xm_type(GdkRectangle, GdkRectangle)
-Xm_type_Ptr(GtkTextLayout_, GtkTextLayout*)
#endif
#if GTK_CHECK_VERSION(3, 22, 0)
@@ -967,6 +960,12 @@ Xm_type_Ptr(GtkTextLayout_, GtkTextLayout*)
#define Xen_to_C_GdkAxisFlags(Arg) (GdkAxisFlags)(Xen_integer_to_C_int(Arg))
#define Xen_is_GdkAxisFlags(Arg) Xen_is_integer(Arg)
Xm_type_Ptr(GdkDeviceTool_, GdkDeviceTool*)
+Xm_type_Ptr(GdkMonitor_, GdkMonitor*)
+Xm_type(gtk_menu_place_on_monitor, gtk_menu_place_on_monitor)
+Xm_type(menu, menu)
+#define C_to_Xen_GdkSubpixelLayout(Arg) C_int_to_Xen_integer(Arg)
+#define Xen_to_C_GdkSubpixelLayout(Arg) (GdkSubpixelLayout)(Xen_integer_to_C_int(Arg))
+#define Xen_is_GdkSubpixelLayout(Arg) Xen_is_integer(Arg)
#endif
Xm_type_Ptr(cairo_surface_t_, cairo_surface_t*)
@@ -14967,14 +14966,6 @@ static Xen gxg_gdk_display_get_name(Xen display)
return(C_to_Xen_gchar_(gdk_display_get_name(Xen_to_C_GdkDisplay_(display))));
}
-static Xen gxg_gdk_display_get_screen(Xen display, Xen screen_num)
-{
- #define H_gdk_display_get_screen "GdkScreen* gdk_display_get_screen(GdkDisplay* display, int screen_num)"
- Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_screen", "GdkDisplay*");
- Xen_check_type(Xen_is_int(screen_num), screen_num, 2, "gdk_display_get_screen", "int");
- return(C_to_Xen_GdkScreen_(gdk_display_get_screen(Xen_to_C_GdkDisplay_(display), Xen_to_C_int(screen_num))));
-}
-
static Xen gxg_gdk_display_get_default_screen(Xen display)
{
#define H_gdk_display_get_default_screen "GdkScreen* gdk_display_get_default_screen(GdkDisplay* display)"
@@ -32049,17 +32040,6 @@ static Xen gxg_gtk_widget_get_focus_on_click(Xen widget)
return(C_to_Xen_gboolean(gtk_widget_get_focus_on_click(Xen_to_C_GtkWidget_(widget))));
}
-static Xen gxg_gtk_widget_get_allocated_size(Xen widget, Xen ignore_allocation, Xen ignore_baseline)
-{
- #define H_gtk_widget_get_allocated_size "void gtk_widget_get_allocated_size(GtkWidget* widget, GtkAllocation* [allocation], \
-int* [baseline])"
- GtkAllocation ref_allocation;
- int ref_baseline;
- Xen_check_type(Xen_is_GtkWidget_(widget), widget, 1, "gtk_widget_get_allocated_size", "GtkWidget*");
- gtk_widget_get_allocated_size(Xen_to_C_GtkWidget_(widget), &ref_allocation, &ref_baseline);
- return(Xen_list_2(C_to_Xen_GtkAllocation(ref_allocation), C_to_Xen_int(ref_baseline)));
-}
-
static Xen gxg_gdk_drag_context_get_drag_window(Xen context)
{
#define H_gdk_drag_context_get_drag_window "GdkWindow* gdk_drag_context_get_drag_window(GdkDragContext* context)"
@@ -32148,28 +32128,34 @@ gint hot_x, gint hot_y)"
static Xen gxg_gdk_seat_grab(Xen arglist)
{
#define H_gdk_seat_grab "GdkGrabStatus gdk_seat_grab(GdkSeat* seat, GdkWindow* window, GdkSeatCapabilities capabilities, \
-gboolean owner_events, GdkCursor* cursor, const GdkEvent*, event GdkSeatGrabPrepareFunc, prepare_func lambda_data, \
-prepare_func_data)"
- Xen seat, window, capabilities, owner_events, cursor, GdkEvent*, GdkSeatGrabPrepareFunc, lambda_data;
+gboolean owner_events, GdkCursor* cursor, GdkEvent* event, GdkSeatGrabPrepareFunc prepare_func, lambda_data func_info)"
+ Xen seat, window, capabilities, owner_events, cursor, event, prepare_func, func_info;
seat = Xen_list_ref(arglist, 0);
window = Xen_list_ref(arglist, 1);
capabilities = Xen_list_ref(arglist, 2);
owner_events = Xen_list_ref(arglist, 3);
cursor = Xen_list_ref(arglist, 4);
- GdkEvent* = Xen_list_ref(arglist, 5);
- GdkSeatGrabPrepareFunc = Xen_list_ref(arglist, 6);
- lambda_data = Xen_list_ref(arglist, 7);
+ event = Xen_list_ref(arglist, 5);
+ prepare_func = Xen_list_ref(arglist, 6);
+ func_info = Xen_list_ref(arglist, 7);
Xen_check_type(Xen_is_GdkSeat_(seat), seat, 1, "gdk_seat_grab", "GdkSeat*");
Xen_check_type(Xen_is_GdkWindow_(window), window, 2, "gdk_seat_grab", "GdkWindow*");
Xen_check_type(Xen_is_GdkSeatCapabilities(capabilities), capabilities, 3, "gdk_seat_grab", "GdkSeatCapabilities");
Xen_check_type(Xen_is_gboolean(owner_events), owner_events, 4, "gdk_seat_grab", "gboolean");
Xen_check_type(Xen_is_GdkCursor_(cursor), cursor, 5, "gdk_seat_grab", "GdkCursor*");
- Xen_check_type(Xen_is_const(GdkEvent*), GdkEvent*, 6, "gdk_seat_grab", "const");
- Xen_check_type(Xen_is_event(GdkSeatGrabPrepareFunc), GdkSeatGrabPrepareFunc, 7, "gdk_seat_grab", "event");
- Xen_check_type(Xen_is_prepare_func(lambda_data), lambda_data, 8, "gdk_seat_grab", "prepare_func");
- return(C_to_Xen_GdkGrabStatus(gdk_seat_grab(Xen_to_C_GdkSeat_(seat), Xen_to_C_GdkWindow_(window), Xen_to_C_GdkSeatCapabilities(capabilities),
- Xen_to_C_gboolean(owner_events), Xen_to_C_GdkCursor_(cursor), Xen_to_C_const(GdkEvent*),
- Xen_to_C_event(GdkSeatGrabPrepareFunc), Xen_to_C_prepare_func(lambda_data))));
+ Xen_check_type(Xen_is_GdkEvent_(event), event, 6, "gdk_seat_grab", "GdkEvent*");
+ Xen_check_type(Xen_is_GdkSeatGrabPrepareFunc(prepare_func), prepare_func, 7, "gdk_seat_grab", "GdkSeatGrabPrepareFunc");
+ if (!Xen_is_bound(func_info)) func_info = Xen_false;
+ else Xen_check_type(Xen_is_lambda_data(func_info), func_info, 8, "gdk_seat_grab", "lambda_data");
+ {
+ Xen result;
+ Xen gxg_ptr = Xen_list_5(Xen_false, func_info, Xen_false, Xen_false, Xen_false);
+ xm_protect(gxg_ptr);
+ result = C_to_Xen_GdkGrabStatus(gdk_seat_grab(Xen_to_C_GdkSeat_(seat), Xen_to_C_GdkWindow_(window), Xen_to_C_GdkSeatCapabilities(capabilities),
+ Xen_to_C_gboolean(owner_events), Xen_to_C_GdkCursor_(cursor), Xen_to_C_GdkEvent_(event),
+ Xen_to_C_GdkSeatGrabPrepareFunc(prepare_func), Xen_to_C_lambda_data(func_info)));
+ return(result);
+ }
}
static Xen gxg_gdk_seat_ungrab(Xen seat)
@@ -32242,50 +32228,6 @@ static Xen gxg_gtk_text_view_reset_cursor_blink(Xen text_view)
return(Xen_false);
}
-static Xen gxg_gtk_render_background_get_clip(Xen context, Xen x, Xen y, Xen width, Xen height, Xen ignore_out_clip)
-{
- #define H_gtk_render_background_get_clip "void gtk_render_background_get_clip(GtkStyleContext* context, \
-gdouble x, gdouble y, gdouble width, gdouble height, GdkRectangle* [out_clip])"
- GdkRectangle ref_out_clip;
- Xen_check_type(Xen_is_GtkStyleContext_(context), context, 1, "gtk_render_background_get_clip", "GtkStyleContext*");
- Xen_check_type(Xen_is_gdouble(x), x, 2, "gtk_render_background_get_clip", "gdouble");
- Xen_check_type(Xen_is_gdouble(y), y, 3, "gtk_render_background_get_clip", "gdouble");
- Xen_check_type(Xen_is_gdouble(width), width, 4, "gtk_render_background_get_clip", "gdouble");
- Xen_check_type(Xen_is_gdouble(height), height, 5, "gtk_render_background_get_clip", "gdouble");
- gtk_render_background_get_clip(Xen_to_C_GtkStyleContext_(context), Xen_to_C_gdouble(x), Xen_to_C_gdouble(y), Xen_to_C_gdouble(width),
- Xen_to_C_gdouble(height), &ref_out_clip);
- return(Xen_list_1(C_to_Xen_GdkRectangle(ref_out_clip)));
-}
-
-static Xen gxg_gtk_text_layout_get_iter_at_pixel(Xen layout, Xen iter, Xen x, Xen y)
-{
- #define H_gtk_text_layout_get_iter_at_pixel "gboolean gtk_text_layout_get_iter_at_pixel(GtkTextLayout* layout, \
-GtkTextIter* iter, gint x, gint y)"
- Xen_check_type(Xen_is_GtkTextLayout_(layout), layout, 1, "gtk_text_layout_get_iter_at_pixel", "GtkTextLayout*");
- Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_layout_get_iter_at_pixel", "GtkTextIter*");
- Xen_check_type(Xen_is_gint(x), x, 3, "gtk_text_layout_get_iter_at_pixel", "gint");
- Xen_check_type(Xen_is_gint(y), y, 4, "gtk_text_layout_get_iter_at_pixel", "gint");
- return(C_to_Xen_gboolean(gtk_text_layout_get_iter_at_pixel(Xen_to_C_GtkTextLayout_(layout), Xen_to_C_GtkTextIter_(iter),
- Xen_to_C_gint(x), Xen_to_C_gint(y))));
-}
-
-static Xen gxg_gtk_text_layout_get_iter_at_position(Xen layout, Xen iter, Xen ignore_trailing, Xen x, Xen y)
-{
- #define H_gtk_text_layout_get_iter_at_position "gboolean gtk_text_layout_get_iter_at_position(GtkTextLayout* layout, \
-GtkTextIter* iter, gint* [trailing], gint x, gint y)"
- gint ref_trailing;
- Xen_check_type(Xen_is_GtkTextLayout_(layout), layout, 1, "gtk_text_layout_get_iter_at_position", "GtkTextLayout*");
- Xen_check_type(Xen_is_GtkTextIter_(iter), iter, 2, "gtk_text_layout_get_iter_at_position", "GtkTextIter*");
- Xen_check_type(Xen_is_gint(x), x, 4, "gtk_text_layout_get_iter_at_position", "gint");
- Xen_check_type(Xen_is_gint(y), y, 5, "gtk_text_layout_get_iter_at_position", "gint");
- {
- Xen result;
- result = C_to_Xen_gboolean(gtk_text_layout_get_iter_at_position(Xen_to_C_GtkTextLayout_(layout), Xen_to_C_GtkTextIter_(iter),
- &ref_trailing, Xen_to_C_gint(x), Xen_to_C_gint(y)));
- return(Xen_list_2(result, C_to_Xen_gint(ref_trailing)));
- }
-}
-
#endif
#if GTK_CHECK_VERSION(3, 22, 0)
@@ -32372,6 +32314,142 @@ static Xen gxg_gdk_device_tool_get_serial(Xen tool)
return(C_to_Xen_guint(gdk_device_tool_get_serial(Xen_to_C_GdkDeviceTool_(tool))));
}
+static Xen gxg_gdk_display_get_n_monitors(Xen display)
+{
+ #define H_gdk_display_get_n_monitors "int gdk_display_get_n_monitors(GdkDisplay* display)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_n_monitors", "GdkDisplay*");
+ return(C_to_Xen_int(gdk_display_get_n_monitors(Xen_to_C_GdkDisplay_(display))));
+}
+
+static Xen gxg_gdk_display_get_monitor(Xen display, Xen monitor_num)
+{
+ #define H_gdk_display_get_monitor "GdkMonitor* gdk_display_get_monitor(GdkDisplay* display, int monitor_num)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_monitor", "GdkDisplay*");
+ Xen_check_type(Xen_is_int(monitor_num), monitor_num, 2, "gdk_display_get_monitor", "int");
+ return(C_to_Xen_GdkMonitor_(gdk_display_get_monitor(Xen_to_C_GdkDisplay_(display), Xen_to_C_int(monitor_num))));
+}
+
+static Xen gxg_gdk_display_get_primary_monitor(Xen display)
+{
+ #define H_gdk_display_get_primary_monitor "GdkMonitor* gdk_display_get_primary_monitor(GdkDisplay* display)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_primary_monitor", "GdkDisplay*");
+ return(C_to_Xen_GdkMonitor_(gdk_display_get_primary_monitor(Xen_to_C_GdkDisplay_(display))));
+}
+
+static Xen gxg_gdk_display_get_monitor_at_point(Xen display, Xen x, Xen y)
+{
+ #define H_gdk_display_get_monitor_at_point "GdkMonitor* gdk_display_get_monitor_at_point(GdkDisplay* display, \
+int x, int y)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_monitor_at_point", "GdkDisplay*");
+ Xen_check_type(Xen_is_int(x), x, 2, "gdk_display_get_monitor_at_point", "int");
+ Xen_check_type(Xen_is_int(y), y, 3, "gdk_display_get_monitor_at_point", "int");
+ return(C_to_Xen_GdkMonitor_(gdk_display_get_monitor_at_point(Xen_to_C_GdkDisplay_(display), Xen_to_C_int(x), Xen_to_C_int(y))));
+}
+
+static Xen gxg_gdk_display_get_monitor_at_window(Xen display, Xen window)
+{
+ #define H_gdk_display_get_monitor_at_window "GdkMonitor* gdk_display_get_monitor_at_window(GdkDisplay* display, \
+GdkWindow* window)"
+ Xen_check_type(Xen_is_GdkDisplay_(display), display, 1, "gdk_display_get_monitor_at_window", "GdkDisplay*");
+ Xen_check_type(Xen_is_GdkWindow_(window), window, 2, "gdk_display_get_monitor_at_window", "GdkWindow*");
+ return(C_to_Xen_GdkMonitor_(gdk_display_get_monitor_at_window(Xen_to_C_GdkDisplay_(display), Xen_to_C_GdkWindow_(window))));
+}
+
+static Xen gxg_gdk_event_get_pointer_emulated(Xen event)
+{
+ #define H_gdk_event_get_pointer_emulated "gboolean gdk_event_get_pointer_emulated(GdkEvent* event)"
+ Xen_check_type(Xen_is_GdkEvent_(event), event, 1, "gdk_event_get_pointer_emulated", "GdkEvent*");
+ return(C_to_Xen_gboolean(gdk_event_get_pointer_emulated(Xen_to_C_GdkEvent_(event))));
+}
+
+static Xen gxg_GtkMenu*(Xen GdkMonitor*)
+{
+ #define H_GtkMenu* "gtk_menu_place_on_monitor GtkMenu*(menu GdkMonitor*, monitor)"
+ Xen_check_type(Xen_is_menu(GdkMonitor*), GdkMonitor*, 1, "GtkMenu*", "menu");
+ return(C_to_Xen_gtk_menu_place_on_monitor(GtkMenu*(Xen_to_C_menu(GdkMonitor*))));
+}
+
+static Xen gxg_gdk_monitor_get_display(Xen monitor)
+{
+ #define H_gdk_monitor_get_display "GdkDisplay* gdk_monitor_get_display(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_display", "GdkMonitor*");
+ return(C_to_Xen_GdkDisplay_(gdk_monitor_get_display(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_geometry(Xen monitor, Xen geometry)
+{
+ #define H_gdk_monitor_get_geometry "void gdk_monitor_get_geometry(GdkMonitor* monitor, GdkRectangle* geometry)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_geometry", "GdkMonitor*");
+ Xen_check_type(Xen_is_GdkRectangle_(geometry), geometry, 2, "gdk_monitor_get_geometry", "GdkRectangle*");
+ gdk_monitor_get_geometry(Xen_to_C_GdkMonitor_(monitor), Xen_to_C_GdkRectangle_(geometry));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_monitor_get_workarea(Xen monitor, Xen workarea)
+{
+ #define H_gdk_monitor_get_workarea "void gdk_monitor_get_workarea(GdkMonitor* monitor, GdkRectangle* workarea)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_workarea", "GdkMonitor*");
+ Xen_check_type(Xen_is_GdkRectangle_(workarea), workarea, 2, "gdk_monitor_get_workarea", "GdkRectangle*");
+ gdk_monitor_get_workarea(Xen_to_C_GdkMonitor_(monitor), Xen_to_C_GdkRectangle_(workarea));
+ return(Xen_false);
+}
+
+static Xen gxg_gdk_monitor_get_width_mm(Xen monitor)
+{
+ #define H_gdk_monitor_get_width_mm "int gdk_monitor_get_width_mm(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_width_mm", "GdkMonitor*");
+ return(C_to_Xen_int(gdk_monitor_get_width_mm(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_height_mm(Xen monitor)
+{
+ #define H_gdk_monitor_get_height_mm "int gdk_monitor_get_height_mm(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_height_mm", "GdkMonitor*");
+ return(C_to_Xen_int(gdk_monitor_get_height_mm(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_manufacturer(Xen monitor)
+{
+ #define H_gdk_monitor_get_manufacturer "char* gdk_monitor_get_manufacturer(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_manufacturer", "GdkMonitor*");
+ return(C_to_Xen_char_(gdk_monitor_get_manufacturer(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_model(Xen monitor)
+{
+ #define H_gdk_monitor_get_model "char* gdk_monitor_get_model(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_model", "GdkMonitor*");
+ return(C_to_Xen_char_(gdk_monitor_get_model(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_scale_factor(Xen monitor)
+{
+ #define H_gdk_monitor_get_scale_factor "int gdk_monitor_get_scale_factor(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_scale_factor", "GdkMonitor*");
+ return(C_to_Xen_int(gdk_monitor_get_scale_factor(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_refresh_rate(Xen monitor)
+{
+ #define H_gdk_monitor_get_refresh_rate "int gdk_monitor_get_refresh_rate(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_refresh_rate", "GdkMonitor*");
+ return(C_to_Xen_int(gdk_monitor_get_refresh_rate(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_get_subpixel_layout(Xen monitor)
+{
+ #define H_gdk_monitor_get_subpixel_layout "GdkSubpixelLayout gdk_monitor_get_subpixel_layout(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_get_subpixel_layout", "GdkMonitor*");
+ return(C_to_Xen_GdkSubpixelLayout(gdk_monitor_get_subpixel_layout(Xen_to_C_GdkMonitor_(monitor))));
+}
+
+static Xen gxg_gdk_monitor_is_primary(Xen monitor)
+{
+ #define H_gdk_monitor_is_primary "gboolean gdk_monitor_is_primary(GdkMonitor* monitor)"
+ Xen_check_type(Xen_is_GdkMonitor_(monitor), monitor, 1, "gdk_monitor_is_primary", "GdkMonitor*");
+ return(C_to_Xen_gboolean(gdk_monitor_is_primary(Xen_to_C_GdkMonitor_(monitor))));
+}
+
#endif
static Xen gxg_cairo_create(Xen target)
@@ -35030,6 +35108,7 @@ static Xen gxg_GDK_SEAT(Xen obj) {return((Xen_is_wrapped_object(obj)) ? Xen_list
#if GTK_CHECK_VERSION(3, 22, 0)
static Xen gxg_GDK_DEVICE_TOOL(Xen obj) {return((Xen_is_wrapped_object(obj)) ? Xen_list_2(xg_GdkDeviceTool__symbol, Xen_cadr(obj)) : Xen_false);}
+static Xen gxg_GDK_MONITOR(Xen obj) {return((Xen_is_wrapped_object(obj)) ? Xen_list_2(xg_GdkMonitor__symbol, Xen_cadr(obj)) : Xen_false);}
#endif
static Xen gxg_GDK_IS_DRAG_CONTEXT(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_DRAG_CONTEXT((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
@@ -35246,6 +35325,7 @@ static Xen gxg_GDK_IS_SEAT(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped
#if GTK_CHECK_VERSION(3, 22, 0)
static Xen gxg_GDK_IS_DEVICE_TOOL(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_DEVICE_TOOL((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
+static Xen gxg_GDK_IS_MONITOR(Xen obj) {return(C_bool_to_Xen_boolean(Xen_is_wrapped_object(obj) && GDK_IS_MONITOR((GTypeInstance *)Xen_unwrap_C_pointer(Xen_cadr(obj)))));}
#endif
@@ -35481,7 +35561,8 @@ static Xen xg_gtk_event_keyval(Xen event)
{
GdkEventKey *e;
e = Xen_to_C_GdkEventKey_(event);
- if (e) return(C_int_to_Xen_integer((int)(e->keyval))); return(XEN_ZERO);
+ if (e) return(C_int_to_Xen_integer((int)(e->keyval)));
+ return(XEN_ZERO);
}
static Xen xen_list_to_c_array(Xen val, Xen type)
@@ -37121,7 +37202,6 @@ Xen_wrap_3_args(gxg_gtk_tree_store_reorder_w, gxg_gtk_tree_store_reorder)
Xen_wrap_3_args(gxg_gtk_tree_store_swap_w, gxg_gtk_tree_store_swap)
Xen_wrap_1_arg(gxg_gdk_display_open_w, gxg_gdk_display_open)
Xen_wrap_1_arg(gxg_gdk_display_get_name_w, gxg_gdk_display_get_name)
-Xen_wrap_2_args(gxg_gdk_display_get_screen_w, gxg_gdk_display_get_screen)
Xen_wrap_1_arg(gxg_gdk_display_get_default_screen_w, gxg_gdk_display_get_default_screen)
Xen_wrap_1_arg(gxg_gdk_display_beep_w, gxg_gdk_display_beep)
Xen_wrap_1_arg(gxg_gdk_display_sync_w, gxg_gdk_display_sync)
@@ -39061,7 +39141,6 @@ Xen_wrap_3_args(gxg_gtk_widget_path_iter_set_object_name_w, gxg_gtk_widget_path_
Xen_wrap_1_arg(gxg_gtk_widget_queue_allocate_w, gxg_gtk_widget_queue_allocate)
Xen_wrap_2_args(gxg_gtk_widget_set_focus_on_click_w, gxg_gtk_widget_set_focus_on_click)
Xen_wrap_1_arg(gxg_gtk_widget_get_focus_on_click_w, gxg_gtk_widget_get_focus_on_click)
-Xen_wrap_3_optional_args(gxg_gtk_widget_get_allocated_size_w, gxg_gtk_widget_get_allocated_size)
Xen_wrap_1_arg(gxg_gdk_drag_context_get_drag_window_w, gxg_gdk_drag_context_get_drag_window)
Xen_wrap_2_args(gxg_gtk_popover_set_constrain_to_w, gxg_gtk_popover_set_constrain_to)
Xen_wrap_1_arg(gxg_gtk_popover_get_constrain_to_w, gxg_gtk_popover_get_constrain_to)
@@ -39082,9 +39161,6 @@ Xen_wrap_1_arg(gxg_gdk_seat_get_keyboard_w, gxg_gdk_seat_get_keyboard)
Xen_wrap_3_args(gxg_gdk_drag_context_manage_dnd_w, gxg_gdk_drag_context_manage_dnd)
Xen_wrap_1_arg(gxg_gdk_event_is_scroll_stop_event_w, gxg_gdk_event_is_scroll_stop_event)
Xen_wrap_1_arg(gxg_gtk_text_view_reset_cursor_blink_w, gxg_gtk_text_view_reset_cursor_blink)
-Xen_wrap_6_optional_args(gxg_gtk_render_background_get_clip_w, gxg_gtk_render_background_get_clip)
-Xen_wrap_4_args(gxg_gtk_text_layout_get_iter_at_pixel_w, gxg_gtk_text_layout_get_iter_at_pixel)
-Xen_wrap_5_optional_args(gxg_gtk_text_layout_get_iter_at_position_w, gxg_gtk_text_layout_get_iter_at_position)
#endif
#if GTK_CHECK_VERSION(3, 22, 0)
@@ -39099,6 +39175,24 @@ Xen_wrap_1_arg(gxg_gtk_clipboard_get_selection_w, gxg_gtk_clipboard_get_selectio
Xen_wrap_2_args(gxg_gtk_gl_area_set_use_es_w, gxg_gtk_gl_area_set_use_es)
Xen_wrap_1_arg(gxg_gtk_gl_area_get_use_es_w, gxg_gtk_gl_area_get_use_es)
Xen_wrap_1_arg(gxg_gdk_device_tool_get_serial_w, gxg_gdk_device_tool_get_serial)
+Xen_wrap_1_arg(gxg_gdk_display_get_n_monitors_w, gxg_gdk_display_get_n_monitors)
+Xen_wrap_2_args(gxg_gdk_display_get_monitor_w, gxg_gdk_display_get_monitor)
+Xen_wrap_1_arg(gxg_gdk_display_get_primary_monitor_w, gxg_gdk_display_get_primary_monitor)
+Xen_wrap_3_args(gxg_gdk_display_get_monitor_at_point_w, gxg_gdk_display_get_monitor_at_point)
+Xen_wrap_2_args(gxg_gdk_display_get_monitor_at_window_w, gxg_gdk_display_get_monitor_at_window)
+Xen_wrap_1_arg(gxg_gdk_event_get_pointer_emulated_w, gxg_gdk_event_get_pointer_emulated)
+Xen_wrap_1_arg(gxg_GtkMenu*_w, gxg_GtkMenu*)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_display_w, gxg_gdk_monitor_get_display)
+Xen_wrap_2_args(gxg_gdk_monitor_get_geometry_w, gxg_gdk_monitor_get_geometry)
+Xen_wrap_2_args(gxg_gdk_monitor_get_workarea_w, gxg_gdk_monitor_get_workarea)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_width_mm_w, gxg_gdk_monitor_get_width_mm)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_height_mm_w, gxg_gdk_monitor_get_height_mm)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_manufacturer_w, gxg_gdk_monitor_get_manufacturer)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_model_w, gxg_gdk_monitor_get_model)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_scale_factor_w, gxg_gdk_monitor_get_scale_factor)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_refresh_rate_w, gxg_gdk_monitor_get_refresh_rate)
+Xen_wrap_1_arg(gxg_gdk_monitor_get_subpixel_layout_w, gxg_gdk_monitor_get_subpixel_layout)
+Xen_wrap_1_arg(gxg_gdk_monitor_is_primary_w, gxg_gdk_monitor_is_primary)
#endif
Xen_wrap_1_arg(gxg_cairo_create_w, gxg_cairo_create)
@@ -39609,6 +39703,7 @@ Xen_wrap_1_arg(gxg_GDK_SEAT_w, gxg_GDK_SEAT)
#if GTK_CHECK_VERSION(3, 22, 0)
Xen_wrap_1_arg(gxg_GDK_DEVICE_TOOL_w, gxg_GDK_DEVICE_TOOL)
+Xen_wrap_1_arg(gxg_GDK_MONITOR_w, gxg_GDK_MONITOR)
#endif
Xen_wrap_1_arg(gxg_GDK_IS_DRAG_CONTEXT_w, gxg_GDK_IS_DRAG_CONTEXT)
@@ -39825,11 +39920,12 @@ Xen_wrap_1_arg(gxg_GDK_IS_SEAT_w, gxg_GDK_IS_SEAT)
#if GTK_CHECK_VERSION(3, 22, 0)
Xen_wrap_1_arg(gxg_GDK_IS_DEVICE_TOOL_w, gxg_GDK_IS_DEVICE_TOOL)
+Xen_wrap_1_arg(gxg_GDK_IS_MONITOR_w, gxg_GDK_IS_MONITOR)
#endif
#if HAVE_SCHEME
static s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_gtk_enum_t, s_pair_false;
-static s7_pointer pl_iur, pl_iuisi, pl_pig, pl_iuuui, pl_iuuuui, pl_iuis, pl_iug, pl_ius, pl_iusi, pl_iu, pl_iuui, pl_pi, pl_iui, pl_iuisut, pl_piu, pl_pit, pl_t, pl_tts, pl_tti, pl_dust, pl_dut, pl_du, pl_dusr, pl_dus, pl_pr, pl_s, pl_tsb, pl_st, pl_tsu, pl_tsig, pl_ts, pl_tsi, pl_tsiu, pl_tsiiuui, pl_tsiuui, pl_p, pl_igi, pl_gi, pl_ssig, pl_ssi, pl_tusiuiuit, pl_turrrru, pl_tubu, pl_tuurru, pl_tuurrrrgr, pl_tuurrrrg, pl_tuuur, pl_tusg, pl_tuuuui, pl_tuusb, pl_tugui, pl_turru, pl_tuuugi, pl_tuuuub, pl_tuttti, pl_tuuttti, pl_tuisi, pl_tugb, pl_tugs, pl_tugug, pl_turgs, pl_tubi, pl_tuttigsi, pl_tuiiiiui, pl_tuurb, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_tuiggu, pl_turrrb, pl_tuubbi, pl_tuubbig, pl_pt, pl_tuuti, pl_tubbi, pl_tusiu, pl_tuuutti, pl_tuti, pl_tutti, pl_tutui, pl_tutisi, pl_tuuri, pl_tuusit, pl_tuurbr, pl_tuuiu, pl_tugiiu, pl_tuugi, pl_tuit, pl_tusr, pl_tusrt, pl_tusi, pl_turt, pl_tuui, pl_tut, pl_tuur, pl_tuig, pl_tur, pl_tub, pl_tui, pl_tu, pl_tus, pl_tuiiu, pl_tusb, pl_tuuut, pl_tug, pl_tutb, pl_tust, pl_tuub, pl_tuus, pl_tuug, pl_tuibu, pl_tuut, pl_tuuig, pl_tuguig, pl_tuubr, pl_tuuub, pl_tuuiuui, pl_tugu, pl_tuuir, pl_tugr, pl_tugi, pl_tuuui, pl_tuib, pl_tusu, pl_tuusi, pl_tugt, pl_tuis, pl_tuiu, pl_tubiiiu, pl_tusiis, pl_tusiuiu, pl_tusiuibu, pl_tusiiu, pl_tuuug, pl_tusuig, pl_tuuubr, pl_psgi, pl_suiig, pl_sug, pl_psgbiiiit, pl_psrrrb, pl_sui, pl_suuub, pl_psu, pl_psb, pl_su, pl_sus, pl_ps, pl_psg, pl_psi, pl_psugt, pl_psut, pl_g, pl_pur, pl_puuui, pl_puiu, pl_pusiig, pl_pusiigu, pl_pusiiugu, pl_puuiig, pl_puur, pl_puiiui, pl_pugi, pl_puuig, pl_pubi, pl_puiig, pl_puiigi, pl_puigu, pl_puuusuug, pl_pusi, pl_puri, pl_pusub, pl_pust, pl_pub, pl_pu, pl_puutu, pl_pui, pl_pusu, pl_pus, pl_pug, pl_put, pl_pusigu, pl_pusig, pl_puui, pl_pusiiu, pl_tg, pl_sg, pl_gs, pl_gussitu, pl_gurrsiu, pl_gus, pl_guut, pl_guuut, pl_guiu, pl_guugbut, pl_pgr, pl_pgu, pl_pgi, pl_gug, pl_pgbi, pl_gu, pl_gugu, pl_pg, pl_gui, pl_big, pl_bi, pl_b, pl_btiib, pl_bti, pl_bt, pl_tb, pl_bsiu, pl_bsiuub, pl_bsu, pl_bsigb, pl_bsiiuusu, pl_bur, pl_buug, pl_buut, pl_buigu, pl_busiu, pl_buuti, pl_buttiiiu, pl_butib, pl_buiuig, pl_buuusuug, pl_buuit, pl_butu, pl_buti, pl_butti, pl_busi, pl_buusib, pl_busib, pl_buuuub, pl_buuub, pl_buttu, pl_busgu, pl_buurbr, pl_buui, pl_buus, pl_buuui, pl_busu, pl_bug, pl_bu, pl_buuubu, pl_bus, pl_bui, pl_buutuuiu, pl_but, pl_bussu, pl_buib, pl_buiu, pl_buiiu, pl_bub, pl_buub, pl_pb, pl_buig, pl_buuiiu, pl_buuig, pl_iiit, pl_iit, pl_i, pl_itiiub, pl_itsub, pl_itstttg, pl_itgiiut, pl_tiu, pl_ti, pl_it, pl_isigutttiiu, pl_isi, pl_isgt, pl_sig, pl_si, pl_is, pl_trrru, pl_bpt;
+static s7_pointer pl_iur, pl_iuisi, pl_pig, pl_iuuui, pl_iuuuui, pl_iuis, pl_iug, pl_ius, pl_iusi, pl_iu, pl_iuui, pl_pi, pl_iui, pl_iuisut, pl_piu, pl_pit, pl_t, pl_tts, pl_tti, pl_g, pl_dust, pl_dut, pl_du, pl_dusr, pl_dus, pl_pr, pl_s, pl_tg, pl_tsb, pl_st, pl_tsu, pl_tsig, pl_ts, pl_tsi, pl_tsiu, pl_tsiiuui, pl_tsiuui, pl_sg, pl_p, pl_gs, pl_ssig, pl_ssi, pl_tusiuiuit, pl_tubu, pl_tuurru, pl_tuurrrrgr, pl_tuurrrrg, pl_tuuur, pl_tusg, pl_tuuuui, pl_tuusb, pl_tugui, pl_turru, pl_tuuugi, pl_tuuuub, pl_tuttti, pl_tuuttti, pl_tuisi, pl_tugb, pl_tugs, pl_tugug, pl_turgs, pl_tubi, pl_tuttigsi, pl_tuiiiiui, pl_tuurb, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_tuiggu, pl_turrrb, pl_tuubbi, pl_tuubbig, pl_pt, pl_tuuti, pl_tubbi, pl_tusiu, pl_tuuutti, pl_tuti, pl_tutti, pl_tutui, pl_tutisi, pl_tuuri, pl_tuusit, pl_tuurbr, pl_tuuiu, pl_tugiiu, pl_tuugi, pl_tuit, pl_tusr, pl_tusrt, pl_tusi, pl_turt, pl_tuui, pl_tut, pl_tuur, pl_tuig, pl_tur, pl_tub, pl_tui, pl_tu, pl_tus, pl_tuiiu, pl_tusb, pl_tuuut, pl_tug, pl_tutb, pl_tust, pl_tuub, pl_tuus, pl_tuug, pl_tuibu, pl_tuut, pl_tuuig, pl_tuguig, pl_tuubr, pl_tuuub, pl_tuuiuui, pl_tugu, pl_tuuir, pl_tugr, pl_tugi, pl_tuuui, pl_tuib, pl_tusu, pl_tuusi, pl_tugt, pl_tuis, pl_tuiu, pl_tubiiiu, pl_tusiis, pl_tusiuiu, pl_tusiuibu, pl_tusiiu, pl_tuuug, pl_tusuig, pl_tuuubr, pl_gussitu, pl_gurrsiu, pl_gus, pl_guut, pl_guuut, pl_guiu, pl_guugbuut, pl_pgr, pl_pgu, pl_pgi, pl_gug, pl_pgbi, pl_gu, pl_gugu, pl_pg, pl_gui, pl_psgi, pl_suiig, pl_sug, pl_psgbiiiit, pl_psrrrb, pl_sui, pl_suuub, pl_psu, pl_psb, pl_su, pl_sus, pl_ps, pl_psg, pl_psi, pl_psugt, pl_psut, pl_pur, pl_puuui, pl_puiu, pl_pusiig, pl_pusiigu, pl_pusiiugu, pl_puuiig, pl_puur, pl_puiiui, pl_pugi, pl_puuig, pl_pubi, pl_puiig, pl_puiigi, pl_puigu, pl_puuusuug, pl_pusi, pl_puri, pl_pusub, pl_pust, pl_pub, pl_pu, pl_puutu, pl_pui, pl_pusu, pl_pus, pl_pug, pl_put, pl_pusigu, pl_pusig, pl_puui, pl_pusiiu, pl_big, pl_bi, pl_b, pl_btiib, pl_bti, pl_bt, pl_tb, pl_bsiu, pl_bsiuub, pl_bsu, pl_bsigb, pl_bsiiuusu, pl_bur, pl_buug, pl_buut, pl_buigu, pl_busiu, pl_buuti, pl_buttiiiu, pl_butib, pl_buiuig, pl_buuusuug, pl_buuit, pl_butu, pl_buti, pl_butti, pl_busi, pl_buusib, pl_busib, pl_buuuub, pl_buuub, pl_buttu, pl_busgu, pl_buurbr, pl_buui, pl_buus, pl_buuui, pl_busu, pl_bug, pl_bu, pl_buuubu, pl_bus, pl_bui, pl_buutuuiu, pl_but, pl_bussu, pl_buib, pl_buiu, pl_buiiu, pl_bub, pl_buub, pl_pb, pl_buig, pl_buuiiu, pl_buuig, pl_iiit, pl_iit, pl_i, pl_itiiub, pl_itsub, pl_itstttg, pl_itgiiut, pl_tiu, pl_ti, pl_it, pl_igi, pl_gi, pl_isigutttiiu, pl_isi, pl_isgt, pl_sig, pl_si, pl_is, pl_trrru, pl_bpt;
#endif
static void define_functions(void)
@@ -39870,6 +39966,7 @@ static void define_functions(void)
pl_t = s7_make_circular_signature(s7, 0, 1, s_any);
pl_tts = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_string);
pl_tti = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_integer);
+ pl_g = s7_make_circular_signature(s7, 0, 1, s_gtk_enum_t);
pl_dust = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_any);
pl_dut = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_any);
pl_du = s7_make_circular_signature(s7, 1, 2, s_float, s_pair_false);
@@ -39877,6 +39974,7 @@ static void define_functions(void)
pl_dus = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_string);
pl_pr = s7_make_circular_signature(s7, 1, 2, s_pair, s_real);
pl_s = s7_make_circular_signature(s7, 0, 1, s_string);
+ pl_tg = s7_make_circular_signature(s7, 1, 2, s_any, s_gtk_enum_t);
pl_tsb = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_boolean);
pl_st = s7_make_circular_signature(s7, 1, 2, s_string, s_any);
pl_tsu = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_pair_false);
@@ -39886,13 +39984,12 @@ static void define_functions(void)
pl_tsiu = s7_make_circular_signature(s7, 3, 4, s_any, s_string, s_integer, s_pair_false);
pl_tsiiuui = s7_make_circular_signature(s7, 6, 7, s_any, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_integer);
pl_tsiuui = s7_make_circular_signature(s7, 5, 6, s_any, s_string, s_integer, s_pair_false, s_pair_false, s_integer);
+ pl_sg = s7_make_circular_signature(s7, 1, 2, s_string, s_gtk_enum_t);
pl_p = s7_make_circular_signature(s7, 0, 1, s_pair);
- pl_igi = s7_make_circular_signature(s7, 2, 3, s_integer, s_gtk_enum_t, s_integer);
- pl_gi = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_integer);
+ pl_gs = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_string);
pl_ssig = s7_make_circular_signature(s7, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t);
pl_ssi = s7_make_circular_signature(s7, 2, 3, s_string, s_string, s_integer);
pl_tusiuiuit = s7_make_circular_signature(s7, 8, 9, s_any, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false, s_integer, s_any);
- pl_turrrru = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_real, s_real, s_real, s_real, s_pair_false);
pl_tubu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_boolean, s_pair_false);
pl_tuurru = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_real, s_pair_false);
pl_tuurrrrgr = s7_make_circular_signature(s7, 8, 9, s_any, s_pair_false, s_pair_false, s_real, s_real, s_real, s_real, s_gtk_enum_t, s_real);
@@ -39986,6 +40083,22 @@ static void define_functions(void)
pl_tuuug = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t);
pl_tusuig = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_gtk_enum_t);
pl_tuuubr = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean, s_real);
+ pl_gussitu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false);
+ pl_gurrsiu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false);
+ pl_gus = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_string);
+ pl_guut = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any);
+ pl_guuut = s7_make_circular_signature(s7, 4, 5, s_gtk_enum_t, s_pair_false, s_pair_false, s_pair_false, s_any);
+ pl_guiu = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_integer, s_pair_false);
+ pl_guugbuut = s7_make_circular_signature(s7, 7, 8, s_gtk_enum_t, s_pair_false, s_pair_false, s_gtk_enum_t, s_boolean, s_pair_false, s_pair_false, s_any);
+ pl_pgr = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_real);
+ pl_pgu = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_pair_false);
+ pl_pgi = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_integer);
+ pl_gug = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_gtk_enum_t);
+ pl_pgbi = s7_make_circular_signature(s7, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer);
+ pl_gu = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_pair_false);
+ pl_gugu = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_gtk_enum_t, s_pair_false);
+ pl_pg = s7_make_circular_signature(s7, 1, 2, s_pair, s_gtk_enum_t);
+ pl_gui = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_integer);
pl_psgi = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_gtk_enum_t, s_integer);
pl_suiig = s7_make_circular_signature(s7, 4, 5, s_string, s_pair_false, s_integer, s_integer, s_gtk_enum_t);
pl_sug = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_gtk_enum_t);
@@ -40002,7 +40115,6 @@ static void define_functions(void)
pl_psi = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_integer);
pl_psugt = s7_make_circular_signature(s7, 4, 5, s_pair, s_string, s_pair_false, s_gtk_enum_t, s_any);
pl_psut = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_pair_false, s_any);
- pl_g = s7_make_circular_signature(s7, 0, 1, s_gtk_enum_t);
pl_pur = s7_make_circular_signature(s7, 2, 3, s_pair, s_pair_false, s_real);
pl_puuui = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_pair_false, s_pair_false, s_integer);
pl_puiu = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_integer, s_pair_false);
@@ -40035,25 +40147,6 @@ static void define_functions(void)
pl_pusig = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_string, s_integer, s_gtk_enum_t);
pl_puui = s7_make_circular_signature(s7, 3, 4, s_pair, s_pair_false, s_pair_false, s_integer);
pl_pusiiu = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_string, s_integer, s_integer, s_pair_false);
- pl_tg = s7_make_circular_signature(s7, 1, 2, s_any, s_gtk_enum_t);
- pl_sg = s7_make_circular_signature(s7, 1, 2, s_string, s_gtk_enum_t);
- pl_gs = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_string);
- pl_gussitu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false);
- pl_gurrsiu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false);
- pl_gus = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_string);
- pl_guut = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any);
- pl_guuut = s7_make_circular_signature(s7, 4, 5, s_gtk_enum_t, s_pair_false, s_pair_false, s_pair_false, s_any);
- pl_guiu = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_integer, s_pair_false);
- pl_guugbut = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_pair_false, s_gtk_enum_t, s_boolean, s_pair_false, s_any);
- pl_pgr = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_real);
- pl_pgu = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_pair_false);
- pl_pgi = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_integer);
- pl_gug = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_gtk_enum_t);
- pl_pgbi = s7_make_circular_signature(s7, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer);
- pl_gu = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_pair_false);
- pl_gugu = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_gtk_enum_t, s_pair_false);
- pl_pg = s7_make_circular_signature(s7, 1, 2, s_pair, s_gtk_enum_t);
- pl_gui = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_integer);
pl_big = s7_make_circular_signature(s7, 2, 3, s_boolean, s_integer, s_gtk_enum_t);
pl_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer);
pl_b = s7_make_circular_signature(s7, 0, 1, s_boolean);
@@ -40119,6 +40212,8 @@ static void define_functions(void)
pl_tiu = s7_make_circular_signature(s7, 2, 3, s_any, s_integer, s_pair_false);
pl_ti = s7_make_circular_signature(s7, 1, 2, s_any, s_integer);
pl_it = s7_make_circular_signature(s7, 1, 2, s_integer, s_any);
+ pl_igi = s7_make_circular_signature(s7, 2, 3, s_integer, s_gtk_enum_t, s_integer);
+ pl_gi = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_integer);
pl_isigutttiiu = s7_make_circular_signature(s7, 10, 11, s_integer, s_string, s_integer, s_gtk_enum_t, s_pair_false, s_any, s_any, s_any, s_integer, s_integer, s_pair_false);
pl_isi = s7_make_circular_signature(s7, 2, 3, s_integer, s_string, s_integer);
pl_isgt = s7_make_circular_signature(s7, 3, 4, s_integer, s_string, s_gtk_enum_t, s_any);
@@ -41555,7 +41650,6 @@ static void define_functions(void)
Xg_define_procedure(gtk_tree_store_swap, gxg_gtk_tree_store_swap_w, 3, 0, 0, H_gtk_tree_store_swap, pl_tu);
Xg_define_procedure(gdk_display_open, gxg_gdk_display_open_w, 1, 0, 0, H_gdk_display_open, pl_ps);
Xg_define_procedure(gdk_display_get_name, gxg_gdk_display_get_name_w, 1, 0, 0, H_gdk_display_get_name, pl_su);
- Xg_define_procedure(gdk_display_get_screen, gxg_gdk_display_get_screen_w, 2, 0, 0, H_gdk_display_get_screen, pl_pui);
Xg_define_procedure(gdk_display_get_default_screen, gxg_gdk_display_get_default_screen_w, 1, 0, 0, H_gdk_display_get_default_screen, pl_pu);
Xg_define_procedure(gdk_display_beep, gxg_gdk_display_beep_w, 1, 0, 0, H_gdk_display_beep, pl_tu);
Xg_define_procedure(gdk_display_sync, gxg_gdk_display_sync_w, 1, 0, 0, H_gdk_display_sync, pl_tu);
@@ -43495,7 +43589,6 @@ static void define_functions(void)
Xg_define_procedure(gtk_widget_queue_allocate, gxg_gtk_widget_queue_allocate_w, 1, 0, 0, H_gtk_widget_queue_allocate, pl_tu);
Xg_define_procedure(gtk_widget_set_focus_on_click, gxg_gtk_widget_set_focus_on_click_w, 2, 0, 0, H_gtk_widget_set_focus_on_click, pl_tub);
Xg_define_procedure(gtk_widget_get_focus_on_click, gxg_gtk_widget_get_focus_on_click_w, 1, 0, 0, H_gtk_widget_get_focus_on_click, pl_bu);
- Xg_define_procedure(gtk_widget_get_allocated_size, gxg_gtk_widget_get_allocated_size_w, 1, 2, 0, H_gtk_widget_get_allocated_size, pl_tu);
Xg_define_procedure(gdk_drag_context_get_drag_window, gxg_gdk_drag_context_get_drag_window_w, 1, 0, 0, H_gdk_drag_context_get_drag_window, pl_pu);
Xg_define_procedure(gtk_popover_set_constrain_to, gxg_gtk_popover_set_constrain_to_w, 2, 0, 0, H_gtk_popover_set_constrain_to, pl_tug);
Xg_define_procedure(gtk_popover_get_constrain_to, gxg_gtk_popover_get_constrain_to_w, 1, 0, 0, H_gtk_popover_get_constrain_to, pl_gu);
@@ -43506,7 +43599,7 @@ static void define_functions(void)
Xg_define_procedure(gdk_drag_begin_from_point, gxg_gdk_drag_begin_from_point_w, 5, 0, 0, H_gdk_drag_begin_from_point, pl_puuui);
Xg_define_procedure(gdk_drag_drop_done, gxg_gdk_drag_drop_done_w, 2, 0, 0, H_gdk_drag_drop_done, pl_tub);
Xg_define_procedure(gdk_drag_context_set_hotspot, gxg_gdk_drag_context_set_hotspot_w, 3, 0, 0, H_gdk_drag_context_set_hotspot, pl_tui);
- Xg_define_procedure(gdk_seat_grab, gxg_gdk_seat_grab_w, 0, 0, 1, H_gdk_seat_grab, pl_guugbut);
+ Xg_define_procedure(gdk_seat_grab, gxg_gdk_seat_grab_w, 0, 0, 1, H_gdk_seat_grab, pl_guugbuut);
Xg_define_procedure(gdk_seat_ungrab, gxg_gdk_seat_ungrab_w, 1, 0, 0, H_gdk_seat_ungrab, pl_tu);
Xg_define_procedure(gdk_seat_get_display, gxg_gdk_seat_get_display_w, 1, 0, 0, H_gdk_seat_get_display, pl_pu);
Xg_define_procedure(gdk_seat_get_capabilities, gxg_gdk_seat_get_capabilities_w, 1, 0, 0, H_gdk_seat_get_capabilities, pl_gu);
@@ -43516,9 +43609,6 @@ static void define_functions(void)
Xg_define_procedure(gdk_drag_context_manage_dnd, gxg_gdk_drag_context_manage_dnd_w, 3, 0, 0, H_gdk_drag_context_manage_dnd, pl_buug);
Xg_define_procedure(gdk_event_is_scroll_stop_event, gxg_gdk_event_is_scroll_stop_event_w, 1, 0, 0, H_gdk_event_is_scroll_stop_event, pl_bu);
Xg_define_procedure(gtk_text_view_reset_cursor_blink, gxg_gtk_text_view_reset_cursor_blink_w, 1, 0, 0, H_gtk_text_view_reset_cursor_blink, pl_tu);
- Xg_define_procedure(gtk_render_background_get_clip, gxg_gtk_render_background_get_clip_w, 5, 1, 0, H_gtk_render_background_get_clip, pl_turrrru);
- Xg_define_procedure(gtk_text_layout_get_iter_at_pixel, gxg_gtk_text_layout_get_iter_at_pixel_w, 4, 0, 0, H_gtk_text_layout_get_iter_at_pixel, pl_buui);
- Xg_define_procedure(gtk_text_layout_get_iter_at_position, gxg_gtk_text_layout_get_iter_at_position_w, 4, 1, 0, H_gtk_text_layout_get_iter_at_position, pl_buuui);
#endif
#if GTK_CHECK_VERSION(3, 22, 0)
@@ -43533,6 +43623,24 @@ static void define_functions(void)
Xg_define_procedure(gtk_gl_area_set_use_es, gxg_gtk_gl_area_set_use_es_w, 2, 0, 0, H_gtk_gl_area_set_use_es, pl_tub);
Xg_define_procedure(gtk_gl_area_get_use_es, gxg_gtk_gl_area_get_use_es_w, 1, 0, 0, H_gtk_gl_area_get_use_es, pl_bu);
Xg_define_procedure(gdk_device_tool_get_serial, gxg_gdk_device_tool_get_serial_w, 1, 0, 0, H_gdk_device_tool_get_serial, pl_iu);
+ Xg_define_procedure(gdk_display_get_n_monitors, gxg_gdk_display_get_n_monitors_w, 1, 0, 0, H_gdk_display_get_n_monitors, pl_iu);
+ Xg_define_procedure(gdk_display_get_monitor, gxg_gdk_display_get_monitor_w, 2, 0, 0, H_gdk_display_get_monitor, pl_pui);
+ Xg_define_procedure(gdk_display_get_primary_monitor, gxg_gdk_display_get_primary_monitor_w, 1, 0, 0, H_gdk_display_get_primary_monitor, pl_pu);
+ Xg_define_procedure(gdk_display_get_monitor_at_point, gxg_gdk_display_get_monitor_at_point_w, 3, 0, 0, H_gdk_display_get_monitor_at_point, pl_pui);
+ Xg_define_procedure(gdk_display_get_monitor_at_window, gxg_gdk_display_get_monitor_at_window_w, 2, 0, 0, H_gdk_display_get_monitor_at_window, pl_pu);
+ Xg_define_procedure(gdk_event_get_pointer_emulated, gxg_gdk_event_get_pointer_emulated_w, 1, 0, 0, H_gdk_event_get_pointer_emulated, pl_bu);
+ Xg_define_procedure(GtkMenu*, gxg_GtkMenu*_w, 1, 0, 0, H_GtkMenu*, pl_t);
+ Xg_define_procedure(gdk_monitor_get_display, gxg_gdk_monitor_get_display_w, 1, 0, 0, H_gdk_monitor_get_display, pl_pu);
+ Xg_define_procedure(gdk_monitor_get_geometry, gxg_gdk_monitor_get_geometry_w, 2, 0, 0, H_gdk_monitor_get_geometry, pl_tu);
+ Xg_define_procedure(gdk_monitor_get_workarea, gxg_gdk_monitor_get_workarea_w, 2, 0, 0, H_gdk_monitor_get_workarea, pl_tu);
+ Xg_define_procedure(gdk_monitor_get_width_mm, gxg_gdk_monitor_get_width_mm_w, 1, 0, 0, H_gdk_monitor_get_width_mm, pl_iu);
+ Xg_define_procedure(gdk_monitor_get_height_mm, gxg_gdk_monitor_get_height_mm_w, 1, 0, 0, H_gdk_monitor_get_height_mm, pl_iu);
+ Xg_define_procedure(gdk_monitor_get_manufacturer, gxg_gdk_monitor_get_manufacturer_w, 1, 0, 0, H_gdk_monitor_get_manufacturer, pl_su);
+ Xg_define_procedure(gdk_monitor_get_model, gxg_gdk_monitor_get_model_w, 1, 0, 0, H_gdk_monitor_get_model, pl_su);
+ Xg_define_procedure(gdk_monitor_get_scale_factor, gxg_gdk_monitor_get_scale_factor_w, 1, 0, 0, H_gdk_monitor_get_scale_factor, pl_iu);
+ Xg_define_procedure(gdk_monitor_get_refresh_rate, gxg_gdk_monitor_get_refresh_rate_w, 1, 0, 0, H_gdk_monitor_get_refresh_rate, pl_iu);
+ Xg_define_procedure(gdk_monitor_get_subpixel_layout, gxg_gdk_monitor_get_subpixel_layout_w, 1, 0, 0, H_gdk_monitor_get_subpixel_layout, pl_gu);
+ Xg_define_procedure(gdk_monitor_is_primary, gxg_gdk_monitor_is_primary_w, 1, 0, 0, H_gdk_monitor_is_primary, pl_bu);
#endif
Xg_define_procedure(cairo_create, gxg_cairo_create_w, 1, 0, 0, H_cairo_create, pl_pu);
@@ -44035,6 +44143,7 @@ static void define_functions(void)
#if GTK_CHECK_VERSION(3, 22, 0)
Xg_define_procedure(GDK_DEVICE_TOOL, gxg_GDK_DEVICE_TOOL_w, 1, 0, 0, "(GDK_DEVICE_TOOL obj) casts obj to GDK_DEVICE_TOOL", pl_bpt);
+ Xg_define_procedure(GDK_MONITOR, gxg_GDK_MONITOR_w, 1, 0, 0, "(GDK_MONITOR obj) casts obj to GDK_MONITOR", pl_bpt);
#endif
Xg_define_procedure(c-array->list, c_array_to_xen_list_w, 2, 0, 0, NULL, NULL);
@@ -44439,6 +44548,8 @@ static void define_functions(void)
#if GTK_CHECK_VERSION(3, 22, 0)
Xg_define_procedure(GDK_IS_DEVICE_TOOL, gxg_GDK_IS_DEVICE_TOOL_w, 1, 0, 0,
"(GDK_IS_DEVICE_TOOL obj): " PROC_TRUE " if obj is a GDK_IS_DEVICE_TOOL", pl_bt);
+ Xg_define_procedure(GDK_IS_MONITOR, gxg_GDK_IS_MONITOR_w, 1, 0, 0,
+ "(GDK_IS_MONITOR obj): " PROC_TRUE " if obj is a GDK_IS_MONITOR", pl_bt);
#endif
}
@@ -45660,6 +45771,12 @@ static void define_integers(void)
define_integer(GDK_DEVICE_TOOL_TYPE_AIRBRUSH);
define_integer(GDK_DEVICE_TOOL_TYPE_MOUSE);
define_integer(GDK_DEVICE_TOOL_TYPE_LENS);
+ define_integer(GDK_SUBPIXEL_LAYOUT_UNKNOWN);
+ define_integer(GDK_SUBPIXEL_LAYOUT_NONE);
+ define_integer(GDK_SUBPIXEL_LAYOUT_HORIZONTAL_RGB);
+ define_integer(GDK_SUBPIXEL_LAYOUT_HORIZONTAL_BGR);
+ define_integer(GDK_SUBPIXEL_LAYOUT_VERTICAL_RGB);
+ define_integer(GDK_SUBPIXEL_LAYOUT_VERTICAL_BGR);
#endif
define_integer(CAIRO_STATUS_SUCCESS);
@@ -45855,17 +45972,16 @@ static void define_atoms(void)
static void define_symbols(void)
{
+ xg_GdkSubpixelLayout_symbol = C_string_to_Xen_symbol("GdkSubpixelLayout");
+ xg_menu_symbol = C_string_to_Xen_symbol("menu");
+ xg_gtk_menu_place_on_monitor_symbol = C_string_to_Xen_symbol("gtk_menu_place_on_monitor");
+ xg_GdkMonitor__symbol = C_string_to_Xen_symbol("GdkMonitor_");
xg_GdkDeviceTool__symbol = C_string_to_Xen_symbol("GdkDeviceTool_");
xg_GdkAxisFlags_symbol = C_string_to_Xen_symbol("GdkAxisFlags");
- xg_GtkTextLayout__symbol = C_string_to_Xen_symbol("GtkTextLayout_");
- xg_GdkRectangle_symbol = C_string_to_Xen_symbol("GdkRectangle");
- xg_prepare_func_symbol = C_string_to_Xen_symbol("prepare_func");
- xg_event_symbol = C_string_to_Xen_symbol("event");
- xg_const_symbol = C_string_to_Xen_symbol("const");
+ xg_GdkSeatGrabPrepareFunc_symbol = C_string_to_Xen_symbol("GdkSeatGrabPrepareFunc");
xg_GdkSeatCapabilities_symbol = C_string_to_Xen_symbol("GdkSeatCapabilities");
xg_GdkGrabStatus_symbol = C_string_to_Xen_symbol("GdkGrabStatus");
xg_GtkPopoverConstraint_symbol = C_string_to_Xen_symbol("GtkPopoverConstraint");
- xg_GtkAllocation_symbol = C_string_to_Xen_symbol("GtkAllocation");
xg_GtkShortcutsWindow__symbol = C_string_to_Xen_symbol("GtkShortcutsWindow_");
xg_GtkStackSidebar__symbol = C_string_to_Xen_symbol("GtkStackSidebar_");
xg_GtkSearchEntry__symbol = C_string_to_Xen_symbol("GtkSearchEntry_");
@@ -46297,7 +46413,6 @@ static void define_symbols(void)
xg_gssize_symbol = C_string_to_Xen_symbol("gssize");
xg_gunichar__symbol = C_string_to_Xen_symbol("gunichar_");
xg_void_symbol = C_string_to_Xen_symbol("void");
- xg_GdkWindow__symbol = C_string_to_Xen_symbol("GdkWindow_");
xg_GdkSeat__symbol = C_string_to_Xen_symbol("GdkSeat_");
xg_GtkRecentInfo__symbol = C_string_to_Xen_symbol("GtkRecentInfo_");
xg_gsize_symbol = C_string_to_Xen_symbol("gsize");
@@ -46335,6 +46450,7 @@ static void define_symbols(void)
xg_gdouble__symbol = C_string_to_Xen_symbol("gdouble_");
xg_GdkEventAny__symbol = C_string_to_Xen_symbol("GdkEventAny_");
xg_GdkEvent__symbol = C_string_to_Xen_symbol("GdkEvent_");
+ xg_GdkWindow__symbol = C_string_to_Xen_symbol("GdkWindow_");
xg_cairo_t__symbol = C_string_to_Xen_symbol("cairo_t_");
xg_cairo_font_options_t__symbol = C_string_to_Xen_symbol("cairo_font_options_t_");
xg_PangoFontDescription__symbol = C_string_to_Xen_symbol("PangoFontDescription_");
@@ -47433,6 +47549,12 @@ static enummer_t enum_info[] = {
{"GDK_DEVICE_TOOL_TYPE_AIRBRUSH", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_AIRBRUSH},
{"GDK_DEVICE_TOOL_TYPE_MOUSE", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_MOUSE},
{"GDK_DEVICE_TOOL_TYPE_LENS", "GdkDeviceToolType", GDK_DEVICE_TOOL_TYPE_LENS},
+ {"GDK_SUBPIXEL_LAYOUT_UNKNOWN", "GdkSubpixelLayout", GDK_SUBPIXEL_LAYOUT_UNKNOWN},
+ {"GDK_SUBPIXEL_LAYOUT_NONE", "GdkSubpixelLayout", GDK_SUBPIXEL_LAYOUT_NONE},
+ {"GDK_SUBPIXEL_LAYOUT_HORIZONTAL_RGB", "GdkSubpixelLayout", GDK_SUBPIXEL_LAYOUT_HORIZONTAL_RGB},
+ {"GDK_SUBPIXEL_LAYOUT_HORIZONTAL_BGR", "GdkSubpixelLayout", GDK_SUBPIXEL_LAYOUT_HORIZONTAL_BGR},
+ {"GDK_SUBPIXEL_LAYOUT_VERTICAL_RGB", "GdkSubpixelLayout", GDK_SUBPIXEL_LAYOUT_VERTICAL_RGB},
+ {"GDK_SUBPIXEL_LAYOUT_VERTICAL_BGR", "GdkSubpixelLayout", GDK_SUBPIXEL_LAYOUT_VERTICAL_BGR},
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
{"GDK_MODIFIER_INTENT_PRIMARY_ACCELERATOR", "GdkModifierIntent", GDK_MODIFIER_INTENT_PRIMARY_ACCELERATOR},
@@ -47624,7 +47746,7 @@ void Init_libxg(void)
#else
Xen_provide_feature("gtk2");
#endif
- Xen_define("xg-version", C_string_to_Xen_string("05-May-16"));
+ Xen_define("xg-version", C_string_to_Xen_string("13-Jun-16"));
xg_already_inited = true;
#if HAVE_SCHEME
#if USE_SND
diff --git a/xm-enved.scm b/xm-enved.scm
index 73a10b6..c715179 100644
--- a/xm-enved.scm
+++ b/xm-enved.scm
@@ -251,12 +251,9 @@
(g_signal_connect_closure_by_id (GPOINTER drawer)
(g_signal_lookup "button_press_event" (G_OBJECT_TYPE (G_OBJECT drawer)))
0 (g_cclosure_new (lambda (w e d)
- (let* ((ev (GDK_EVENT e))
- (coords (gdk_event_get_coords ev))
- (x (cadr coords))
- (y (caddr coords)))
+ (let ((coords (gdk_event_get_coords (GDK_EVENT e))))
(set! dragging #t)
- (xe-mouse-press editor x y))
+ (xe-mouse-press editor (cadr coords) (caddr coords)))
#f)
#f #f)
#f)
@@ -272,8 +269,7 @@
(g_signal_lookup "motion_notify_event" (G_OBJECT_TYPE (G_OBJECT drawer)))
0 (g_cclosure_new (lambda (w e d)
(if dragging
- (let* ((ev (GDK_EVENT e))
- (coords (gdk_event_get_coords ev)))
+ (let ((coords (gdk_event_get_coords (GDK_EVENT e))))
(xe-mouse-drag editor (cadr coords) (caddr coords))))
#f)
#f #f)
diff --git a/xm.c b/xm.c
index e4e0701..d547c54 100644
--- a/xm.c
+++ b/xm.c
@@ -3816,7 +3816,11 @@ static Xen gxm_XmSetColorCalculation(Xen arg1)
#define H_XmSetColorCalculation "XmColorProc XmSetColorCalculation(XmColorProc color_proc) set the procedure used for default color calculation"
/* DIFF: XmSetColorCalculation NULL -> #f
*/
- if (Xen_is_procedure(xm_XmColorProc)) xm_unprotect(xm_XmColorProc);
+ if (Xen_is_procedure(xm_XmColorProc))
+ {
+ xm_unprotect(xm_XmColorProc);
+ xm_XmColorProc = Xen_false; /* in case error below, 17-May-16 */
+ }
if (Xen_is_false(arg1))
{
xm_XmColorProc = Xen_false;
--
snd packaging
More information about the pkg-multimedia-commits
mailing list