Plaster
New
List
Login
commonlisp
default
gingerale
2017.04.18 12:23:50
(cl-out123:connect *out* :driver "pulse") (cl-out123:start *out* :rate 44100 :channels 1 :encoding :float) (cl-out123:play *out* (combine-waves (list (sine-wave 3 :frequency 440) (sine-wave 3 :frequency 880) (sine-wave 3 :frequency 1760)) (list 1 0.5 0.25))) (defun sine-wave (duration &key (frequency 440) (sample-rate 44100)) (let ((length (* duration sample-rate))) (make-array length :element-type 'single-float :initial-contents (let* ((constant (* 2 (coerce pi 'single-float))) (pos-increase (/ frequency sample-rate)) (pos-limit (- 1 pos-increase))) (loop for i from 1 to length for pos = 0 then (+ pos pos-increase (if (<= pos pos-limit) 0 -1)) collect (sin (* pos constant))))))) (defun square-wave (duration &key (frequency 440) (sample-rate 44100)) (let ((length (* duration sample-rate)) (switch (/ sample-rate frequency 2))) (make-array length :element-type 'single-float :initial-contents (loop for i from 1 to length collect (if (= 0 (mod (floor (/ i switch)) 2)) 1.0s0 -1.0s0))))) (defun triangle-wave (duration &key (frequency 440) (sample-rate 44100)) (let ((length (floor (* duration sample-rate)))) (make-array length :element-type 'single-float :initial-contents (let* ((y-inc (/ 4.0s0 (/ sample-rate frequency))) (max-limit (- 1.0s0 y-inc)) (min-limit (+ -1.0s0 y-inc)) (going-up T)) (loop for i from 0 to (1- length) for y = -1.0s0 then (+ y (if going-up y-inc (- y-inc))) when (< max-limit y) do (setf going-up NIL) when (< y min-limit) do (setf going-up T) collect y))))) (defun sawtooth-wave (duration &key (frequency 440) (sample-rate 44100)) (let ((length (* duration sample-rate))) (make-array length :element-type 'single-float :initial-contents (let* ((constant (/ 2.0s0 (/ sample-rate frequency)))) (loop for i from 1 to length for y = 1.0s0 then (- y constant) when (< y -1.0s0) do (incf y 2.0s0) collect y))))) (defun combine-waves (waves &optional amplitudes) (dotimes (i (- (length waves) (length amplitudes))) (push 1 amplitudes)) (let ((output (make-array (loop for wave in waves maximizing (array-dimension wave 0) into max finally (return max)) :element-type 'single-float :initial-element 0.0s0))) (dotimes (i (array-dimension output 0)) (loop for wave in waves for amp in amplitudes do (setf (aref output i) (+ (aref output i) (* amp (aref wave i)))) finally (setf (aref output i) (/ (aref output i) (length waves))))) output))
Raw
Annotate
Repaste
Annotations
commonlisp
default
shinmera
2017.04.18 13:27:18
(defvar *out* (cl-out123:connect (cl-out123:make-output NIL :channels 1 :encoding :float))) (defun square-wave (position length) (if (= 1 (floor (mod position length) (/ length 2))) 1.0s0 0.0s0)) (defun sawtooth-wave (position length) (coerce (/ (mod position length) length) 'single-float)) (defun sine-wave (position length) (sin (* (/ position length) (coerce pi 'single-float)))) (defmacro modincf (i mod &optional (delta 1)) `(setf ,i (mod (+ ,i ,delta) ,mod))) (defun play (wave-type frequency &key (buffer-size 1024)) (cl-out123:start *out*) (unwind-protect (let* ((sample-rate (cl-out123:playback-format *out*)) (sample-length (floor sample-rate frequency)) (j 0)) (cffi:with-foreign-object (buffer :float buffer-size) (loop (loop for i from 0 below buffer-size do (setf (cffi:mem-aref buffer :float i) (funcall wave-type j sample-length)) (modincf j sample-length)) (cl-out123:play-directly *out* buffer buffer-size)))) (cl-out123:stop *out*)))
Raw
Repaste