Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv18370

Modified Files: buffer.lisp gui.lisp packages.lisp play.lisp Log Message: Added support for regular temperaments

--- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/15 16:26:14 1.45 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/18 15:18:17 1.46 @@ -260,6 +260,89 @@ (defun note-equal (note1 note2) (= (pitch note1) (pitch note2)))

+ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Tuning (support for microtonal and historical tunings/temperaments) + +;;; FIXME: add name-mixin also? +(defclass tuning (gsharp-object) + ((master-pitch-note :initform (make-instance 'note :pitch 33 ; a above middle c + :staff (make-instance 'staff)) + :initarg :master-pitch-note + :type note + :accessor master-pitch-note) + (master-pitch-freq :initform 440 + :initarg :master-pitch-freq + :accessor master-pitch-freq))) + +(defmethod print-gsharp-object progn ((tuning tuning) stream) + (format stream "~_:master-pitch-note ~W ~_:master-pitch-freq ~W " + (master-pitch-note tuning) (master-pitch-freq tuning))) + +;;; Returns how a note should be tuned in a given tuning +;;; in terms of a cent value. +(defgeneric note-cents (note tuning)) + +;;; 12-edo is provided for efficiency only. It is a +;;; special case of a regular temperament. Perhaps it +;;; should be removed? +(defclass 12-edo (tuning) + ()) + +(defmethod print-gsharp-object progn ((tuning 12-edo) stream) + ;; no parameters to save + ) + +(defmethod note-cents ((note note) (tuning 12-edo)) + (multiple-value-bind (octave pitch) (floor (pitch note) 7) + (+ (* 1200 (1+ octave)) + (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100)) + (ecase (accidentals note) + (:double-flat -200) + (:flat -100) + (:natural 0) + (:sharp 100) + (:double-sharp 200))))) + +;;; regular temperaments are temperaments that +;;; retain their interval sizes regardless of modulation, as opposed to +;;; irregular temperaments. +(defclass regular-temperament (tuning) + ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents) + (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents)) + ;; TODO: Add cent sizes of various microtonal accidentals, perhaps in an alist? + ) + +(defmethod print-gsharp-object progn ((tuning regular-temperament) stream) + (format stream "~_:octave-cents ~W ~_:fifth-cents ~W " + (octave-cents tuning) (fifth-cents tuning))) + +(defmethod note-cents ((note note) (tuning regular-temperament)) + (let ((octave-cents (octave-cents tuning)) + (fifth-cents (fifth-cents tuning))) + (multiple-value-bind (octave pitch) (floor (pitch note) 7) + (+ (* octave-cents (1+ octave)) + (ecase pitch + (0 0) + (1 (+ (* -1 octave-cents) (* 2 fifth-cents))) + (2 (+ (* -2 octave-cents) (* 4 fifth-cents))) + (3 (- octave-cents fifth-cents)) + (4 fifth-cents) + (5 (+ (* -1 octave-cents) (* 3 fifth-cents))) + (6 (+ (* -2 octave-cents) (* 5 fifth-cents)))) + (* (ecase (accidentals note) + (:double-flat -2) + (:flat -1) + (:natural 0) + (:sharp 1) + (:double-sharp 2)) + (- (* 7 fifth-cents) + (* 4 octave-cents))))))) + +;;; TODO: (defclass irregular-temperament ...) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Element @@ -987,7 +1070,9 @@ ((print-character :allocation :class :initform #\S) (buffer :initform nil :initarg :buffer :accessor buffer) (layers :initform '() :initarg :layers :accessor layers) - (tempo :initform 128 :initarg :tempo :accessor tempo))) + (tempo :initform 128 :initarg :tempo :accessor tempo) + (tuning :initform (make-instance '12-edo) + :initarg :tuning :accessor tuning)))

(defmethod initialize-instance :after ((s segment) &rest args &key staff) (declare (ignore args)) @@ -999,7 +1084,8 @@ do (setf (segment layer) s))))

(defmethod print-gsharp-object progn ((s segment) stream) - (format stream "~_:layers ~W ~_:tempo ~W " (layers s) (tempo s))) + (format stream "~_:layers ~W ~_:tempo ~W ~_:tuning ~W " + (layers s) (tempo s) (tuning s)))

(defun read-segment-v3 (stream char n) (declare (ignore char n)) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/10 08:15:28 1.76 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/18 15:18:17 1.77 @@ -364,6 +364,15 @@ (let ((segment (segment (current-cursor)))) (setf (tempo segment) tempo)))

+(define-gsharp-command (com-set-segment-tuning-regular-temperament :name t) + ((octave-cents 'cl:number :prompt "Octave size in cents") + (fifth-cents 'cl:number :prompt "Fifth size in cents")) + ;; TODO: prompt for sizes of various microtonal accidentals + (let ((segment (segment (current-cursor)))) + (setf (tuning segment) (make-instance 'regular-temperament + :octave-cents octave-cents + :fifth-cents fifth-cents)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; layer menu --- /project/gsharp/cvsroot/gsharp/packages.lisp 2007/01/31 15:25:04 1.59 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2007/06/18 15:18:17 1.60 @@ -94,7 +94,9 @@ #:right-edge #:left-offset #:left-margin #:text #:append-char #:erase-char #:tie-right #:tie-left - #:needs-saving)) + #:needs-saving + #:tuning #:master-pitch-note #:master-pitch-freq + #:note-cents #:12-edo #:regular-temperament))

(defpackage :gsharp-numbering (:use :gsharp-utilities :gsharp-buffer :clim-lisp) --- /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/15 16:26:14 1.6 +++ /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/18 15:18:17 1.7 @@ -1,16 +1,17 @@ (in-package :gsharp-play)

+(defvar *tuning*) +(defvar *tempo*) + (defun midi-pitch (note) - (+ (* 12 (+ (floor (pitch note) 7) 1)) - (ecase (mod (pitch note) 7) (0 0) (1 2) (2 4) (3 5) (4 7) (5 9) (6 11)) - (ecase (accidentals note) - (:double-flat -2) - (:flat -1) - (:natural 0) - (:sharp 1) - (:double-sharp 2)))) + (round (+ (+ 6700 ; a above middle c, 440 Hz + (* 1200 (log (/ (master-pitch-freq *tuning*) 440) 2))) + (- (note-cents note *tuning*) + (note-cents (master-pitch-note *tuning*) *tuning*))) + 100))

-(defvar *tempo*) +(defun cents-adjustment (note) + (nth-value 1 (midi-pitch note)))

(defun measure-durations (slices) (let ((durations (mapcar (lambda (slice) @@ -18,19 +19,40 @@ (bars slice))) slices))) (loop while durations - collect (reduce #'max (mapcar #'car durations)) + collect (reduce #'max durations :key #'car) do (setf durations (remove nil (mapcar #'cdr durations))))))

+(defun average (list &key (key #'identity)) + (let ((sum 0) + (count 0)) + (dolist (elem list) + (incf count) + (incf sum (funcall key elem))) + (/ sum count))) + (defun events-from-element (element time channel) (when (typep element 'cluster) - (append (mapcar (lambda (note) + (append (list + (make-instance 'pitch-bend-message + :time time + :status (+ #xE0 channel) + :value (+ 8192 ;; middle of pitch-bend controller + (round + (* 4096/100 ;; 4096 points per 100 cents + ;; midi can only do per-channel pitch bend, + ;; not per-note pitch bend, so as a sad + ;; compromise we average the pitch bends + ;; of all notes in the cluster + (average (notes element) + :key #'cents-adjustment)))))) + (mapcar (lambda (note) (make-instance 'note-on-message - :time time + :time time :status (+ #x90 channel) :key (midi-pitch note) :velocity 100)) (remove-if #'tie-left (notes element))) - (mapcar (lambda (note) - (make-instance 'note-off-message + (mapcar (lambda (note) + (make-instance 'note-off-message :time (+ time (* *tempo* (duration element))) :status (+ #x80 channel) :key (midi-pitch note) :velocity 100)) @@ -55,6 +77,7 @@ (let* ((slices (mapcar #'body (layers segment))) (durations (measure-durations slices)) (*tempo* (tempo segment)) + (*tuning* (gsharp-buffer:tuning segment)) (tracks (loop for slice in slices for i from 0 collect (track-from-slice slice i durations))) @@ -85,4 +108,3 @@ (sb-ext:run-program "timidity" '("/tmp/test.mid") :search t) #-(or cmu sbcl) (error "write compatibility layer for RUN-PROGRAM"))) -