Menu
▾
▴
[foo-cvs] foo/elkfoo/examples/scripts fsdiary.foo,1.2,1.3
|
From: Martin R. <ru...@us...> - 2007-10-05 15:51:00
|
Update of /cvsroot/foo/foo/elkfoo/examples/scripts
In directory sc8-pr-cvs17:/tmp/cvs-serv15937
Modified Files:
fsdiary.foo
Log Message:
some fixes again
Index: fsdiary.foo
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/examples/scripts/fsdiary.foo,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** fsdiary.foo 30 Sep 2007 13:10:20 -0000 1.2
--- fsdiary.foo 5 Oct 2007 15:50:59 -0000 1.3
***************
*** 24,27 ****
--- 24,28 ----
(("--begin" "-b") #f #t "begin position in source (s) [0]")
(("--end" "-e") #f #t "end position (s) [file end]")))
+
(help
(lambda ()
***************
*** 30,33 ****
--- 31,44 ----
(format #t "~a~%" (cmdline:help-message option-list))
(exit)))
+
+ (error
+ (lambda (error-msg . print-help)
+ (display (format #t "~a: ~a~%" (car (foo:script-args)) error-msg))
+ (if (and (not (null? print-help)) (eq? (car print-help) #t))
+ (begin
+ (newline)
+ (help))
+ (exit))))
+
(infiles)
(outfile)
***************
*** 39,55 ****
(duration)
(xfadelength)
! (xfadetype)
! (begint)
! (endt)
! (curinpos) ;; current infile position
! (curoutpos) ;; current outfile position
! (outinc) ;; outputfile increment
! (normenv~)
! (startenv~)
! (endenv~)
! (overalldur)
! (c) ; context
! (t) ; task
! ;; (maxdur) ; overall duration
)
--- 50,67 ----
(duration)
(xfadelength)
! (xfadeinalpha) ; encodes xfadetype
! (xfadeoutalpha) ; encodes xfadetype
! (begint) ; start offset in infile
! (endt) ; end offset in infile
! (curinpos) ; current infile position
! (curoutpos) ; current outfile position
! (outinc) ; outputfile increment
! (normenv~) ; slice envelope
! (startenv~) ; slice env (first slice)
! (endenv~) ; slice env (last slice)
! (noenv~) ; slice env (only slice: no env)
! (overalldur 0)
! (c) ; context
! (t) ; task
)
***************
*** 66,73 ****
(set! infiles (cmdline:get-arguments (cdr (foo:script-args)) option-list))
(if (null? infiles)
! (begin
! (display "no input files given on commandline!")
! (newline)
! (help))
(letrec
((exists (lambda (files)
--- 78,82 ----
(set! infiles (cmdline:get-arguments (cdr (foo:script-args)) option-list))
(if (null? infiles)
! (error "no input files given on commandline!")
(letrec
((exists (lambda (files)
***************
*** 75,83 ****
((file-exists? (car files)) (exists (cdr files)))
(else
! (display (string-append "input file not found: " (car files)))
! (newline)
! (exit))))))
(exists infiles)))
;; outfile name
(set! outfile (car (cmdline:get-option-param (foo:script-args) option-list "--outfile")))
--- 84,94 ----
((file-exists? (car files)) (exists (cdr files)))
(else
! (error (string-append "input file not found: " (car files))))))))
(exists infiles)))
+ ;; FIXME
+ (if (> (length infiles) 1)
+ (error "multiple input files not yet supported."))
+
;; outfile name
(set! outfile (car (cmdline:get-option-param (foo:script-args) option-list "--outfile")))
***************
*** 124,131 ****
(set! period (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--period"))))
(if (< period 0)
! (begin
! (display "negative period not allowed!")
! (newline)
! (exit)))
;; duration
--- 135,139 ----
(set! period (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--period"))))
(if (< period 0)
! (error "negative period not allowed!"))
;; duration
***************
*** 134,168 ****
(set! duration (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--duration"))))
(if (< duration 0)
! (begin
! (display "negative duration not allowed!")
! (newline)
! (exit))))
(set! duration period))
! ;; xfadelength
(if (cmdline:option-given? (foo:script-args) option-list "--xfadelength")
(begin
(set! xfadelength (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--xfadelength"))))
! (if (< xfadelength 0)
! (begin
! (display "negative xfadelength not allowed!")
! (newline)
! (exit))))
(set! xfadelength 0))
! ;; xfadetype
(if (cmdline:option-given? (foo:script-args) option-list "--xfadetype")
(begin
! (set! xfadetype (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--xfadetype"))))
! (if (not (or (equal? xfadetype 'log)
! (equal? xfadetype 'expon)
! (equal? xfadetype 'line)))
! (begin
! (display "xfadetype not valid!")
! (newline)
! (help))))
! (set! xfadetype 'log))
! ;; begint
(if (cmdline:option-given? (foo:script-args) option-list "--begin")
(set! begint (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--begin"))))
--- 142,178 ----
(set! duration (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--duration"))))
(if (< duration 0)
! (error "negative duration not allowed!")))
(set! duration period))
! ;; xfadelength
(if (cmdline:option-given? (foo:script-args) option-list "--xfadelength")
(begin
(set! xfadelength (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--xfadelength"))))
! (cond
! ((< xfadelength 0)
! (error "negative xfadelength not allowed!"))
! ((> (* 2 xfadelength) duration)
! (error "xfadelength longer than half of duration!"))))
(set! xfadelength 0))
! ;; xfadetype
(if (cmdline:option-given? (foo:script-args) option-list "--xfadetype")
+ (let ((xfadetype (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--xfadetype")))))
+ (cond ((eq? xfadetype 'log)
+ (set! xfadeinalpha 0.1) ;; FIXME
+ (set! xfadeoutalpha 9.9)) ;; FIXME
+ ((eq? xfadetype 'expon)
+ (set! xfadeinalpha 9.9) ;; FIXME
+ (set! xfadeoutalpha 0.1) ;; FIXME
+ ((eq? xfadetype 'line)
+ (set! xfadeinalpha 1)
+ (set! xfadeoutalpha 1))
+ (else
+ (error "xfadetype not valid!" #t)))))
(begin
! (set! xfadeinalpha 0.1) ;; FIXME
! (set! xfadeoutalpha 9.9))) ;; FIXME
! ;; begint
(if (cmdline:option-given? (foo:script-args) option-list "--begin")
(set! begint (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--begin"))))
***************
*** 171,205 ****
;; endt
(if (cmdline:option-given? (foo:script-args) option-list "--end")
! (set! endt (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--end"))))
(set! endt (soundfile-length (car infiles)))) ;; needs further attention
;; outfile increment
(set! outinc (- duration xfadelength))
- ;; overall duration
- (set! overalldur
- (let
- ((numslices (/ (soundfile-length (car infiles)) period)))
- (+ (* (- duration xfadelength)
- (trunc numslices))
- (* duration (- numslices (trunc numslices))))))
-
;; prepare context
(set! c (context channels))
;; make envelope signals
! (if (= xfadelength 0)
! ;; make-bpf needs strictly ascending time values: FIXME!
! (with-context c (lambda ()
! (set! normenv~ (lambda () (~ 1)))
! (set! startenv~ (lambda () (~ 1)))
! (set! endenv~ (lambda () (~ 1)))))
! (with-context c (lambda ()
! (set! normenv~ (lambda () (read-bpf~ (make-bpf (list '(0 0) (list xfadelength 1) (list outinc 1) (list duration 0))))))
! (set! startenv~ (lambda () (read-bpf~ (make-bpf (list '(0 1) (list outinc 1) (list duration 0))))))
! (set! endenv~ (lambda () (read-bpf~ (make-bpf (list '(0 0) (list xfadelength 1) (list duration 1)))))))))
(letrec
! ;; write single slice per channels
((cat-slice (lambda (slice chan off env~)
(if (> chan 0)
--- 181,228 ----
;; endt
(if (cmdline:option-given? (foo:script-args) option-list "--end")
! (begin
! (set! endt (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--end"))))
! (if (> endt (soundfile-length (car infiles)))
! (error "end position beyond end of input file!")))
(set! endt (soundfile-length (car infiles)))) ;; needs further attention
+ (if (< (- endt begint) duration)
+ (error "interval between begin and end positions shorter than one slice!"))
+
;; outfile increment
(set! outinc (- duration xfadelength))
;; prepare context
(set! c (context channels))
;; make envelope signals
! (cond
! ;; make-bpf needs strictly ascending time values
! ;; this is a workaround for zero-length-crossfades: FIXME!
! ((= xfadelength 0)
! (with-context c (lambda ()
! (set! normenv~ (lambda () (~ 1)))
! (set! startenv~ (lambda () (~ 1)))
! (set! endenv~ (lambda () (~ 1)))
! (set! noenv~ (lambda () (~ 1))))))
! ;; make-bpf needs strictly ascending time values
! ;; this is a workaround for a corner-case: no sustain phase
! ((= (* 2 xfadelength) duration)
! (with-context c (lambda ()
! (set! normenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,duration 0 ,xfadeoutalpha))))))
! (set! startenv~ (lambda () (read-bpf~ (make-bpf `((0 1) (,outinc 1) (,duration 0 ,xfadeoutalpha))))))
! (set! endenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,duration 1))))))
! (set! noenv~ (lambda () (~ 1))))))
! ;; in a better foo world, this should be sufficient for all cases
! (else
! (with-context c (lambda ()
! ;; (set! normenv~ (lambda () (read-bpf~ (make-bpf (list '(0 0) (list xfadelength 1 xfadeinalpha) (list outinc 1) (list duration 0 xfadeoutalpha))))))
! (set! normenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,outinc 1) (,duration 0 ,xfadeoutalpha))))))
! (set! startenv~ (lambda () (read-bpf~ (make-bpf `((0 1) (,outinc 1) (,duration 0 ,xfadeoutalpha))))))
! (set! endenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,duration 1))))))
! (set! noenv~ (lambda () (~ 1)))))))
(letrec
! ;; process all channels for one slice
((cat-slice (lambda (slice chan off env~)
(if (> chan 0)
***************
*** 210,236 ****
(cat-slice slice (1- chan) off env~)))))
! ;; write input file per slice
! (cat-slices (lambda (file curoutpos curinpos)
! (let*
! ((snd (open-snd file)))
! (cond
! ;; first slice
! ((= curoutpos 0)
! (begin
! (cat-slice (snd-region snd curinpos duration) channels curoutpos startenv~)
! (cat-slices file (+ curoutpos outinc) (+ curinpos period))))
! ;; last slice truncated
! ((>= (+ curinpos duration) (snd-length snd))
! (cat-slice (snd-region snd curinpos (- (snd-length snd) curinpos)) channels curoutpos endenv~))
! ;; last slice complete
! ((>= (+ curinpos period) (snd-length snd))
! (cat-slice (snd-region snd curinpos duration) channels curoutpos endenv~))
! ;; normal slice
! (else
! (begin
! (cat-slice (snd-region snd curinpos duration) channels curoutpos normenv~)
! (cat-slices file (+ curoutpos outinc) (+ curinpos period)))))))))
! (with-context c (lambda () (cat-slices (car infiles) 0 begint))))
;; soundfile
--- 233,301 ----
(cat-slice slice (1- chan) off env~)))))
! ;; process all slices of input sound
! (cat-slices (lambda (snd curinpos curoutpos)
! (cond
! ;; corner case: first slice is the only slice
! ((and (= curoutpos 0)
! (>= (+ curinpos period) (snd-length snd)))
! (cat-slice (snd-region snd curinpos duration)
! channels
! curoutpos
! noenv~))
! ;; first slice
! ((= curoutpos 0)
! ;; current slice
! (cat-slice (snd-region snd curinpos duration)
! channels
! curoutpos
! startenv~)
! ;; next slice(s)
! (cat-slices snd
! (+ curinpos period)
! (+ curoutpos outinc)))
! ;; last slice truncated
! ((>= (+ curinpos duration) (snd-length snd))
! (cat-slice (snd-region snd curinpos (- (snd-length snd) curinpos))
! channels
! curoutpos
! endenv~))
! ;; last slice complete
! ((>= (+ curinpos period) (snd-length snd))
! (cat-slice (snd-region snd curinpos duration)
! channels
! curoutpos
! endenv~))
! ;; normal slice
! (else
! ;; current slice
! (cat-slice (snd-region snd curinpos duration)
! channels
! curoutpos
! normenv~)
! ;; next slice(s)
! (cat-slices snd
! (+ curinpos period)
! (+ curoutpos outinc)))))))
! ;; kick the ass off
! (with-context c (lambda ()
! (let*
! ((snd (snd-region (open-snd (car infiles))
! begint
! (- endt begint)))
! (numslices (/ (snd-length snd)
! period))
! (lastslice (* (- numslices (trunc numslices))
! (/ period duration)))
! (dur (+ (* (ceiling (1- numslices))
! (- duration xfadelength))
! ;; truc de malade
! (* (if (or (= lastslice 0) (>= lastslice 1))
! duration
! (* lastslice duration))))))
! (set! overalldur (+ overalldur dur))
! (cat-slices snd
! 0
! 0)))))
;; soundfile
***************
*** 238,242 ****
(create-soundfile outfile type format srate channels)
(make-soundfile outfile type format srate channels))
!
;; task
(set! t (make-task 0 0 outfile c 'punch srate))
--- 303,307 ----
(create-soundfile outfile type format srate channels)
(make-soundfile outfile type format srate channels))
!
;; task
(set! t (make-task 0 0 outfile c 'punch srate))
|
