Autres/audacity
1
0
Fork 0
mirror of https://github.com/cookiengineer/audacity synced 2025-11-28 00:00:18 +01:00
Code Issues Releases Wiki Activity

Update Sample Data Export to use file browser

Browse Source
This commit is contained in:
Steve Daulton
2018-06-18 21:31:54 +01:00
parent 5e219a031d
commit 5543dc884a
1 changed files with 157 additions and 279 deletions
Download Patch File Download Diff File Expand all files Collapse all files

436
plug-ins/sample-data-export.ny
View File

@@ -1,15 +1,35 @@
$nyquist plug-in $nyquist plug-in
$version 3 $version 4
$type tool $type tool
$name (_ "Sample Data Export") $name (_ "Sample Data Export")
$manpage "Sample_Data_Export" $manpage "Sample_Data_Export"
$debugbutton false
$action (_ "Analyzing...") $action (_ "Analyzing...")
$maxlen 1000001
$author (_ "Steve Daulton") $author (_ "Steve Daulton")
$copyright (_ "Released under terms of the GNU General Public License version 2") $copyright (_ "Released under terms of the GNU General Public License version 2")
;; sample-data-export.ny by Steve Daulton June 2012.
;; Updated July 16 2012. $control number (_ "Limit output to first") int-text (_ "samples") 100 1 1000000
$control units (_ "Measurement scale") choice ((_ "dB") (_ "Linear")) 0
$control filename (_ "Export data to") file (_ "Select a file") "*default*/sample-data.txt" "Text file|*.txt;*.TXT|CSV files|*.csv;*.CSV|HTML files|*.html;*.HTML;*.htm;*.HTM|All files|*.*;*" "save,overwrite"
$control fileformat (_ "Index (text files only)") choice ((_ "None")
("Count" (_ "Sample Count"))
("Time" (_ "Time Indexed")))
$control header (_ "Include header information") choice ((_ "None")
(_ "Minimal")
(_ "Standard")
(_ "All")) 0
$control optext (_ "Optional header text") string "" ""
$control channel-layout (_ "Channel layout for stereo") choice (;i18n-hint: Left and Right
("SameLine" (_ "L-R on Same Line"))
("Alternate" (_ "Alternate Lines"))
;i18n-hint: L for Left
("LFirst" (_ "L Channel First"))) 0
$control messages (_ "Show messages") choice ((_ "Yes")
("Errors" (_ "Errors Only"))
(_ "None")) 0
;; Released under terms of the GNU General Public License version 2: ;; Released under terms of the GNU General Public License version 2:
;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html ;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
@@ -18,95 +38,58 @@ $copyright (_ "Released under terms of the GNU General Public License version 2"
;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference ;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
$control number (_ "Limit output to first") string (_ "samples") "100" ;; To enable L/R prefix before alternate L/R channels
$control units (_ "Measurement scale") choice (
(_ "dB")
(_ "Linear")
) 0
$control fileformat (_ "File data format") choice (
("SampleList" (_ "Sample List (txt)"))
("IndexedList" (_ "Indexed List (txt)"))
("TimeIndexed" (_ "Time Indexed (txt)"))
;i18n-hint: "comma separated values"
("CSV" (_ "Data (csv)"))
("Web" (_ "Web Page (html)"))
) 0
$control header (_ "Include header information") choice (
(_ "None")
(_ "Minimal")
(_ "Standard")
(_ "All")
) 2
$control optext (_ "Optional header text") string ""
$control chan (_ "Channel layout for stereo") choice (
;i18n-hint: Left and Right
("SameLine" (_ "L-R on Same Line"))
("Alternate" (_ "Alternate Lines"))
;i18n-hint: L for Left
("LFirst" (_ "L Channel First"))
) 0
$control messages (_ "Show messages") choice (
(_ "Yes")
("Errors" (_ "Errors Only"))
(_ "None")
) 0
$control filename (_ "File name") string "" (_ "sample-data")
$control path (_ "Output folder") string "" (_ "Home directory")
$control owrite (_ "Allow files to be overwritten") choice (
(_ "No")
(_ "Yes")
) 0
;; To enable L/R prefix before alternate L/R channels
;; (text output with header only) ;; (text output with header only)
;; remove the semicolon from the start of the next line: ;; remove the semicolon from the start of the next line:
;(setq LR-prefix '("L: " "R: ")) ;(setq LR-prefix '("L: " "R: "))
(when (not (boundp 'LR-prefix))(setq LR-prefix nil)) (when (not (boundp 'LR-prefix))(setq LR-prefix nil))
(setq *float-format* "%1.5f") ; 5 decimal places
(setq default-filename (_ "sample-data")) ; default filename
(setq err "") ; initialise error mesaage
(setq *float-format* "%1.5f") ; 5 decimal places
(when (equal (string-trim " .,\/" number) "")
(setq number "100")) ; default=100
(defun add-error (e-string) ;;; Return file extension or empty string
(setq err (strcat err e-string "\n"))) (defun get-extension (fname)
(let ((n (1- (length fname)))
(ext ""))
(do ((i n (1- i)))
((= i 0) ext)
(when (char= (char fname i) #\.)
(setf ext (subseq fname (1+ i)))
(return ext)))))
;;; stereo peak ;;; stereo peak
(defun stereomax (snd) (defun stereomax (snd)
(if (arrayp s) (if (arrayp *track*)
(max (peak (aref s 0) number)(peak (aref s 1) number)) (max (peak (aref *track* 0) number)
(peak s number))) (peak (aref *track* 1) number))
(peak *track* number)))
;;; stereo rms ;;; stereo rms
(defun srms (snd) (defun srms (snd)
(if (arrayp snd) (if (arrayp snd)
(let* ((sql (mult (aref s 0)(aref s 0))) (let* ((sql (mult (aref *track* 0)(aref *track* 0)))
(sqr (mult (aref s 1)(aref s 1))) (sqr (mult (aref *track* 1)(aref *track* 1)))
(avgsq (mult 0.5 (sum sql sqr))) (avgsq (mult 0.5 (sum sql sqr)))
(avgsq (snd-avg avgsq number number op-average))) (avgsq (snd-avg avgsq number number op-average)))
(lin-to-db (peak (snd-sqrt avgsq) 1))) (lin-to-db (peak (snd-sqrt avgsq) 1)))
(let* ((sndsq (mult snd snd)) (let* ((sndsq (mult snd snd))
(avgsq (snd-avg sndsq number number op-average))) (avgsq (snd-avg sndsq number number op-average)))
(lin-to-db (peak (snd-sqrt avgsq) 1))))) (lin-to-db (peak (snd-sqrt avgsq) 1)))))
;;; dc off-set mono
;;; DC off-set mono
(defun dc-off-mon (sig len) (defun dc-off-mon (sig len)
(let* ((total 0) (let* ((total 0)
(sig (snd-copy sig))) (sig (snd-copy sig))
(dotimes (num (truncate len)) (ln (truncate len)))
(setq total (+ total (snd-fetch sig)))) (dotimes (num ln)
(/ total (float len)))) (setq total (+ total (snd-fetch sig))))
(/ total (float len))))
;;; compute dc offsets (mono/stereo) ;;; DC offset (mono/stereo)
(defun dc-off (sig) (defun dc-off (sig)
(if (arrayp sig) (if (arrayp sig)
(let ((lin0 (dc-off-mon (aref sig 0) number)) (let ((lin0 (dc-off-mon (aref sig 0) number))
@@ -116,73 +99,31 @@ $control owrite (_ "Allow files to be overwritten") choice (
(list lin (lin-to-db (abs lin)))))) (list lin (lin-to-db (abs lin))))))
(defun checknumber () ;;; Platform independent representation of negative infinity
(setq number (min number len))
(if (< number 1)
(add-error (_ "No samples selected.")))
(if (> number 1000000)
(add-error (_ "Cannot export more than 1 million samples.")))
(setq number (truncate number)))
;;; home directory
(defun home ()
(if (windowsp)
(get-env "UserProfile") ; Windows
(get-env "HOME"))) ; Mac / Linux
;;; Check if Windows
(defun windowsp ()
(char= #\\ *file-separator*))
;;; Windows safe linear-to-db
(setf ln10over20 (/ (log 10.0) 20))
(defun lin-to-db (val) (defun lin-to-db (val)
(if (= val 0) (if (= val 0)
;i18n-hint abbreviates negative infinity ;i18n-hint abbreviates negative infinity
(_ "[-inf]") (_ "[-inf]")
(/ (log val) ln10over20))) (linear-to-db val)))
;;; Check if Mac ;;; Get sample and convert to dB if required
(defun macp ()
(string-equal (subseq (get-env "HOME") 0 6) "/Users"))
;;; check if file exists
(defun filep (fname ext &optional (fnum ""))
(let ((fname (format nil "~a~a~a" fname fnum ext)))
(if (open fname) T nil)))
(defun makefilename (fname ext)
;; avoid overwriting files
(if (and (= owrite 0)(filep fname ext))
(do ((num 1 (1+ num)))
((not (filep fname ext num))
(format nil "~a~a~a" fname num ext)))
(strcat fname ext)))
;;; get sample and convert to dB if required
(defun snd-get (snd &optional (dB 0)) (defun snd-get (snd &optional (dB 0))
(if (= dB 0) ; dB scale (if (= dB 0) ; dB scale
(lin-to-db (abs (snd-fetch snd))) (lin-to-db (abs (snd-fetch snd)))
(snd-fetch snd))) ; linear scale (snd-fetch snd))) ; linear scale
;; fileformat 0=Text List, 1=Indexed List, 2=Time Indexed, 3=CSV, ;; fileformat 0=Text List, 1=Sample count index, 2=Time index, 3=CSV,
;; (4=html but not used here). ;; (4=html but not used here).
;; Optional 'same' [line] argument is either 'true' or 'nil' ;; Optional 'same' [line] argument is either 'true' or 'nil'
(defun formatprint (val snd &optional same) (defun formatprint (val snd &optional same)
(case fileformat (case fileformat
(0 (format fp "~a~a" ; text list (0 (format fp "~a~a" ; plain list
(snd-get snd units) (snd-get snd units)
(if same "\t" "\n"))) (if same "\t" "\n")))
(1 (format fp "~a\t~a~a" ; indexed list (1 (format fp "~a\t~a~a" ; count index
val val
(snd-get snd units) (snd-get snd units)
(if same "\t" "\n"))) (if same "\t" "\n")))
(2 (format fp "~a\t~a~a" ; time index (2 (format fp "~a\t~a~a" ; time index
@@ -191,125 +132,63 @@ $control owrite (_ "Allow files to be overwritten") choice (
(if same "\t" "\n"))) (if same "\t" "\n")))
(3 (format fp "~a~a" ; csv (3 (format fp "~a~a" ; csv
(snd-get snd units) (snd-get snd units)
(if (or (= chan 2) same) "," "\n"))))) (if (or (= channel-layout 2) same) "," "\n")))))
;;; Print sample data to file ;;; Print sample data to file
(defun print-text (s-in) (defun print-text (sig)
(do ((n 1 (1+ n))) (do ((n 1 (1+ n)))
((> n number)) ((> n number))
(if (arrayp s-in) ; Stereo (alternate lines) (if (arrayp sig) ; Stereo (alternate lines)
(progn (progn
;; option to prefix alternate lines with L/R ;; option to prefix alternate lines with L/R
(when LR-prefix (when LR-prefix
(unless (or (= header 0)(= fileformat 3)) (unless (or (= header 0)(= fileformat 3))
(format fp "~a" (first LR-prefix)))) (format fp "~a" (first LR-prefix))))
(if (= chan 0) ; IF 'Same Line' then "True" (if (= channel-layout 0) ; IF 'Same Line' then "True"
(formatprint n (aref s-in 0) T) (formatprint n (aref sig 0) T)
(formatprint n (aref s-in 0))) (formatprint n (aref sig 0)))
(when LR-prefix (when LR-prefix
(unless (or (= header 0)(= fileformat 3)) (unless (or (= header 0)(= fileformat 3))
(format fp "~a" (second LR-prefix)))) (format fp "~a" (second LR-prefix))))
(formatprint n (aref s-in 1))) (formatprint n (aref sig 1)))
(formatprint n s-in)))) (formatprint n sig))))
;; Print to file ;; Print to file
(defun printdata () (defun printdata ()
(case header (if (and (arrayp *track*)(= channel-layout 2))
(0 (format t (normhead))(format fp (nohead))) ;; Stereo and left channel first
(1 (format t (normhead))(format fp (minhead)))
(2 (format t (normhead))(format fp (normhead)))
(3 (format t (normhead))(format fp (fullhead))))
;; Stereo and left channel first
(if (and (arrayp s)(= chan 2))
(progn (progn
(unless (= header 0) ; Don't print 'channel' if no header (unless (= header 0) ; Don't print 'channel' if no header
(format fp (_ "Left Channel.~%~%"))) (format fp (_ "Left Channel.~%~%")))
(print-text (aref s 0)) (print-text (aref *track* 0))
(if (= header 0) ; Don't print 'channel' if no header (if (= header 0) ; Don't print 'channel' if no header
(format fp "~%") (format fp "~%")
(format fp (_ "~%~%Right Channel.~%~%"))) (format fp (_ "~%~%Right Channel.~%~%")))
(print-text (aref s 1)) (print-text (aref *track* 1)))
(close fp)
(if (= messages 0)
(format nil (_ "~aData written to:~%~a~a~a")
(normhead) path fileseparator filename)
nil))
;; mono or alternate ;; mono or alternate
(print-text *track*))
(close fp)
(if (= messages 0)
(format nil (_ "~aData written to:~%~a") (normhead) filename)
(progn (progn
(print-text s) (format t (_ "~aData written to:~%~a") (normhead) filename)
(close fp) "")))
(if (= messages 0)
(format nil (_ "~aData written to:~%~a~a~a")
(normhead) path fileseparator filename)
nil))))
;;; File destination processing
(defun filewriter ()
;; Set file extension
(setq FileExt
(case fileformat
(3 ".csv")
(4 ".html")
(T ".txt")))
; file separator as string
(setq fileseparator (format nil "~a" *file-separator*))
;; strip file separator and spaces
(let ((stuff (format nil " ~a" *file-separator*)))
(setq filename (string-left-trim stuff filename))
(setq path (string-right-trim stuff path)))
;; strip file extension if present
(if (and (>= (length filename)(length FileExt))
(string-equal filename FileExt :start1 (- (length filename)(length FileExt))))
(setq filename (subseq filename 0 (- (length filename)(length FileExt)))))
;; replace ~/ on Linux/Max
(if (and (>= (length path) 2)
(not (windowsp)))
(if (string-equal path "~/" :end1 2)
(setq path (strcat (home)(subseq path 1)))))
;; If path not set use home directory
(if (or (string-equal path (_ "Home directory"))
(string-equal path ""))
(setq path (home)))
;; if file name not set use default
(if (string-equal filename "")
(setq filename default-filename))
(setdir (strcat path fileseparator)) ; set target directory
;; set file pointer or error
(let ((realdir (string-right-trim fileseparator (setdir "."))))
(if (or (string= path realdir)
(and (or (windowsp) ; case insensitive
(macp)) ; assume case insensitive
(string-equal path realdir)))
;; makefilename or error
(setq filename (makefilename filename FileExt))
(add-error (format nil (_ "Output folder \"~a~a\" cannot be accessed.")
path fileseparator))))
;; check if file is writeable
(when (= (length err) 0)
;Open file for output
(setq fp (open filename :direction :output))
;check file is writeable
(if (not fp)
(add-error (format nil (_ "\"~a~a~a\" cannot be written.")
path fileseparator filename)))))
;;; Header text ;;; Header text
(defun nohead () (defun nohead ()
(if (> (length optext) 0) (if (> (length optext) 0)
(format nil "~a~%~a~%" (format nil "~a~%~a~%"
optext optext
(get 'info 'chan-order)) (get 'info 'chan-order))
"")) ""))
(defun minhead () (defun minhead ()
(format nil (format nil (_ "Sample Rate: ~a Hz. Sample values on ~a scale.~%~a~%~a")
(_ "Sample Rate: ~a Hz. Sample values on ~a scale.~%~a~%~a")
(get 'info 'srate) ; sample rate (get 'info 'srate) ; sample rate
(get 'info 'units) ; units (get 'info 'units) ; units
(get 'info 'chan-order) ; Channel Order (get 'info 'chan-order) ; Channel Order
@@ -319,38 +198,35 @@ $control owrite (_ "Allow files to be overwritten") choice (
(defun normhead () (defun normhead ()
(if (= fileformat 4) ; html (if (= fileformat 4) ; html
(format nil (format nil (_ "~a ~a~%~aSample Rate: ~a Hz.~%Length processed: ~a samples ~a seconds.~a")
(_ "~a ~a~%~aSample Rate: ~a Hz.~%Length processed: ~a samples ~a seconds.~a") filename ; file name
filename ; file name (get 'info 'channels) ; mono/stereo
(get 'info 'channels) ; mono/stereo (get 'info 'chan-order) ; Channel Order
(get 'info 'chan-order) ; Channel Order (get 'info 'srate) ; sample rate
(get 'info 'srate) ; sample rate number ; number of samples
number ; number of samples (get 'info 'duration) ; duration (seconds)
(get 'info 'duration) ; duration (seconds) (if (> (length optext)0)
(if (> (length optext)0) (format nil "~%~a~%~%" optext) ; optional text
(format nil "~%~a~%~%~%" optext) ; optional text (format nil "~%~%"))) ; no optional text
(format nil "~%~%~%"))) ; no optional text (format nil (_ "~a ~a~%~aSample Rate: ~a Hz. Sample values on ~a scale.~%~
(format nil Length processed: ~a samples ~a seconds.~a")
(_ "~a ~a~%~aSample Rate: ~a Hz. Sample values on ~a scale.~%~ filename ; file name
Length processed: ~a samples ~a seconds.~a") (get 'info 'channels) ; mono/stereo
filename ; file name (get 'info 'chan-order) ; Channel Order
(get 'info 'channels) ; mono/stereo (get 'info 'srate) ; sample rate
(get 'info 'chan-order) ; Channel Order (get 'info 'units) ; units
(get 'info 'srate) ; sample rate number ; number of samples
(get 'info 'units) ; units (get 'info 'duration) ; duration (seconds)
number ; number of samples (if (> (length optext)0)
(get 'info 'duration) ; duration (seconds) (format nil "~%~a~%~%" optext) ; optional text
(if (> (length optext)0) (format nil "~%~%"))))) ; no optional text
(format nil "~%~a~%~%~%" optext) ; optional text
(format nil "~%~%~%"))))) ; no optional text
(defun fullhead () (defun fullhead ()
(format nil (format nil (_ "~a~%Sample Rate: ~a Hz. Sample values on ~a scale. ~a.~%~aLength processed: ~a ~
(_ "~a~%Sample Rate: ~a Hz. Sample values on ~a scale. ~a.~%~aLength processed: ~a ~ samples, ~a seconds.~%Peak amplitude: ~a (linear) ~a dB. Unweighted RMS: ~a dB.~%~
samples, ~a seconds.~%Peak amplitude: ~a (lin) ~a dB. Unweighted RMS: ~a dB.~%~ DC offset: ~a~a")
DC offset: ~a~a")
filename ; file name filename ; file name
(get 'info 'srate) ; sample rate (get 'info 'srate) ; sample rate
(get 'info 'units) ; units (get 'info 'units) ; units
@@ -358,15 +234,15 @@ DC offset: ~a~a")
(get 'info 'chan-order) ; Channel Order (get 'info 'chan-order) ; Channel Order
number ; number of samples number ; number of samples
(get 'info 'duration) ; duration (seconds) (get 'info 'duration) ; duration (seconds)
(setq smax (stereomax s)) ; peak amplitude linear (setq smax (stereomax *track*)) ; peak amplitude linear
(lin-to-db smax) ; peak amplitude dB (lin-to-db smax) ; peak amplitude dB
(srms s) ; rms (srms *track*) ; rms
(let ((vals (dc-off s))) ; DC offset (let ((vals (dc-off *track*))) ; DC offset
(if (= (length vals) 2) ; mono (if (= (length vals) 2) ; mono
(format nil (_ "~a linear, ~a dB.") (format nil (_ "~a linear, ~a dB.")
(first vals)(second vals)) (first vals) (second vals))
(format nil (_ "Left: ~a lin, ~a dB | Right: ~a lin, ~a dB.") (format nil (_ "Left: ~a lin, ~a dB | Right: ~a lin, ~a dB.")
(first vals)(second vals)(third vals)(fourth vals)))) (first vals) (second vals) (third vals) (fourth vals))))
(if (> (length optext)0) (if (> (length optext)0)
(format nil "~%~a~%~%~%" optext) ; optional text (format nil "~%~a~%~%~%" optext) ; optional text
(format nil "~%~%~%")))) ; no optional text (format nil "~%~%~%")))) ; no optional text
@@ -472,8 +348,8 @@ ul {
<h3>" (_ "Audio data analysis:") "</h3> <h3>" (_ "Audio data analysis:") "</h3>
<ul> <ul>
<li>" (_ "<b>Sample Rate:</b> &nbsp;&nbsp;~a Hz.") "</li>" <li>" (_ "<b>Sample Rate:</b> &nbsp;&nbsp;~a Hz.") "</li>"
; i18n-hint: abbreviates "linear" and "decibels" ; i18n-hint: abbreviates "decibels"
"<li>" (_ "<b>Peak Amplitude:</b> &nbsp;&nbsp;~a (lin) &nbsp;&nbsp;~a dB.") "</li>" "<li>" (_ "<b>Peak Amplitude:</b> &nbsp;&nbsp;~a (linear) &nbsp;&nbsp;~a dB.") "</li>"
; i18n-hint: RMS abbreviates root-mean-square, a method of averaging a signal; there also "weighted" versions of it but this isn't that ; i18n-hint: RMS abbreviates root-mean-square, a method of averaging a signal; there also "weighted" versions of it but this isn't that
"<li>" (_ "<b>RMS</b> (unweighted): &nbsp;&nbsp;~a dB.") "</li>" "<li>" (_ "<b>RMS</b> (unweighted): &nbsp;&nbsp;~a dB.") "</li>"
; i18n-hint: DC derives from "direct current" in electronics, really means the zero frequency component of a signal ; i18n-hint: DC derives from "direct current" in electronics, really means the zero frequency component of a signal
@@ -486,12 +362,12 @@ ul {
number ; number of samples number ; number of samples
(get 'info 'duration) ; duration (seconds) (get 'info 'duration) ; duration (seconds)
(get 'info 'srate) ; sample rate (get 'info 'srate) ; sample rate
(setq smax (stereomax s)) ; peak amplitude linear (setq smax (stereomax *track*)) ; peak amplitude linear
(lin-to-db smax) ; peak amplitude dB (lin-to-db smax) ; peak amplitude dB
(srms s) ; rms (srms *track*) ; rms
(let ((vals (dc-off s))) ; DC offset (let ((vals (dc-off *track*))) ; DC offset
(if (= (length vals) 2) ; mono (if (= (length vals) 2) ; mono
(format nil (_ "~a linear, &nbsp;&nbsp;~a dB.") (format nil (_ "~a linear, &nbsp;&nbsp;~a dB.")
(first vals)(second vals)) (first vals)(second vals))
(format nil (_ "Left: ~a lin, ~a dB | Right: ~a linear, &nbsp;&nbsp;~a dB.") (format nil (_ "Left: ~a lin, ~a dB | Right: ~a linear, &nbsp;&nbsp;~a dB.")
(first vals)(second vals)(third vals)(fourth vals)))))) (first vals)(second vals)(third vals)(fourth vals))))))
@@ -539,41 +415,41 @@ Daulton") " (<a href=
(let ((time (/ (1- id) *sound-srate*)) (let ((time (/ (1- id) *sound-srate*))
(db1 (lin-to-db (abs val1))) (db1 (lin-to-db (abs val1)))
(db2 (lin-to-db (abs val2)))) (db2 (lin-to-db (abs val2))))
(format fp (format fp
"<tr>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%~ "<tr>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%~
<td>~a</td>~%<td>~a</td>~%</tr>~%" <td>~a</td>~%<td>~a</td>~%</tr>~%"
id time val1 val2 db1 db2)) id time val1 val2 db1 db2))
;; mono ;; mono
(let ((time (/ (1- id) *sound-srate*)) (let ((time (/ (1- id) *sound-srate*))
(db (lin-to-db (abs val1)))) (db (lin-to-db (abs val1))))
(format fp (format fp
"<tr>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%</tr>~%" "<tr>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%</tr>~%"
id time val1 db)))) id time val1 db))))
(defun printhtml () (defun printhtml ()
(format t (normhead))
(format fp (html-head)) (format fp (html-head))
(format fp (doc-head)) (format fp (doc-head))
(if (arrayp s) (if (arrayp *track*)
(progn (progn
(format fp (table-head-stereo)) (format fp (table-head-stereo))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i number)) ((> i number))
(make-htm i (make-htm i
(snd-fetch (aref s 0)) (snd-fetch (aref *track* 0))
(snd-fetch (aref s 1))))) (snd-fetch (aref *track* 1)))))
(progn (progn
(format fp (table-head-mono)) (format fp (table-head-mono))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i number)) ((> i number))
(make-htm i (snd-fetch s))))) (make-htm i (snd-fetch *track*)))))
(format fp (html-foot)) (format fp (html-foot))
(close fp) (close fp)
(if (= messages 0) (if (= messages 0)
(format nil (_ "~aData written to:~%~a~a~a") (format nil (_ "~aData written to:~%~a") (normhead) filename)
(normhead) path fileseparator filename) (progn
nil)) (format t (_ "~aData written to:~%~a") (normhead) filename)
"")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; END OF HTML ;; ;; END OF HTML ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -584,41 +460,43 @@ Daulton") " (<a href=
(putprop 'info (truncate *sound-srate*) 'srate) (putprop 'info (truncate *sound-srate*) 'srate)
(putprop 'info (if (= units 0) (_ "dB") (_ "linear")) 'units) (putprop 'info (if (= units 0) (_ "dB") (_ "linear")) 'units)
(putprop 'info (/ number *sound-srate*) 'duration) (putprop 'info (/ number *sound-srate*) 'duration)
(putprop 'info (putprop 'info
(if (arrayp s) (if (arrayp *track*)
(_ "2 channels (stereo)") (_ "1 channel (mono)")) (_ "2 channels (stereo)") (_ "1 channel (mono)"))
'channels) 'channels)
;; stereo sample order ;; stereo sample order
(putprop 'info (putprop 'info
(cond (cond
((and (= fileformat 3)(= chan 0)) ; csv, channel in column ((and (= fileformat 3)(= channel-layout 0)) ; csv, channel in column
(format nil (_ "One column per channel.~%"))) (format nil (_ "One column per channel.~%")))
((and (= fileformat 3)(= chan 2)) ; csv, channel in row ((and (= fileformat 3)(= channel-layout 2)) ; csv, channel in row
(format nil (_ "One row per channel.~%"))) (format nil (_ "One row per channel.~%")))
((or (soundp s)(= fileformat 4)) ; mono soundor HTML ((or (soundp *track*)(= fileformat 4)) ; mono sound or HTML
"") "")
((= chan 0) (format nil (_ "Left channel then Right channel on same line.~%"))) ((= channel-layout 0) (format nil (_ "Left channel then Right channel on same line.~%")))
((= chan 1) (format nil (_ "Left and right channels on alternate lines.~%"))) ((= channel-layout 1) (format nil (_ "Left and right channels on alternate lines.~%")))
((= chan 2) (format nil (_ "Left channel first then right channel.~%"))) ((= channel-layout 2) (format nil (_ "Left channel first then right channel.~%")))
(T (_ "Unspecified channel order"))) (T (_ "Unspecified channel order")))
'chan-order)) 'chan-order))
;;; get number from string ;;; Specifying a CSV or HTML file overrides the (text only) format selection.
(setq number (read (make-string-input-stream number))) (let ((file-extension (get-extension filename)))
(if (numberp number) (cond
(checknumber) ((string-equal file-extension "csv")
(add-error (format nil (_ "~a is not a number.") number))) (setf fileformat 3))
((string-equal file-extension "html")
(setf fileformat 4))
((string-equal file-extension "htm")
(setf fileformat 4))))
(filewriter) (setf number (min (truncate len) number))
(if (> (length err) 0) (setq fp (open filename :direction :output))
;; output error message if enabled (cond
(if (= messages 2) (fp (put-head-info)
nil ; return nil (if (= fileformat 4)
(format nil (_ "Error.~%~a") err)) ; return errors (printhtml) ; html output
;; else print to file (printdata))) ; text output
(progn (t (if (= messages 2)
(put-head-info) ; put basic info for headers (format t (_ "Error.~%\"~a\" cannot be written.") filename)
(if (= fileformat 4) (format nil (_ "Error.~%\"~a\" cannot be written.") filename))))
(printhtml) ; html output
(printdata)))) ; text output