[gsharp-cvs] CVS gsharp
mjonsson
mjonsson at common-lisp.net
Mon Jun 18 15:18:17 UTC 2007
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")))
-
More information about the Gsharp-cvs
mailing list