[gsharp-devel] Microtones
Magnus Jonsson
magnus at smartelectronix.com
Sat Jun 16 10:50:40 UTC 2007
Hello all,
I have got basic microtonal support working and I have attached a patch of
my changes. There is no integration with the GUI yet (and I am not sure
how to do that). This patch depends on some bugfixes to the midi package
that have not been released yet (I sent the needed changes to Christophe,
the maintainer of the midi package).
Are the changes and additions in the patch okay with you guys? If so I
will commit it to CVS once the midi package has been updated.
/ Magnus
-------------- next part --------------
cvs diff: Diffing .
Index: buffer.lisp
===================================================================
RCS file: /project/gsharp/cvsroot/gsharp/buffer.lisp,v
retrieving revision 1.45
diff -u -d -r1.45 buffer.lisp
--- buffer.lisp 15 Jun 2007 16:26:14 -0000 1.45
+++ buffer.lisp 16 Jun 2007 10:34:25 -0000
@@ -987,7 +987,8 @@
((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 nil :initarg :tuning :accessor tuning)))
(defmethod initialize-instance :after ((s segment) &rest args &key staff)
(declare (ignore args))
Index: gsharp.asd
===================================================================
RCS file: /project/gsharp/cvsroot/gsharp/gsharp.asd,v
retrieving revision 1.15
diff -u -d -r1.15 gsharp.asd
--- gsharp.asd 31 Jan 2007 15:25:04 -0000 1.15
+++ gsharp.asd 16 Jun 2007 10:34:25 -0000
@@ -37,6 +37,7 @@
"cursor"
"input-state"
"modes"
+ "tuning"
"play"
"gui"
"fontview")
Index: packages.lisp
===================================================================
RCS file: /project/gsharp/cvsroot/gsharp/packages.lisp,v
retrieving revision 1.59
diff -u -d -r1.59 packages.lisp
--- packages.lisp 31 Jan 2007 15:25:04 -0000 1.59
+++ packages.lisp 16 Jun 2007 10:34:31 -0000
@@ -73,7 +73,7 @@
#:layer #:lyrics-layer #:melody-layer
#:bars #:nb-bars #:barno #:add-bar #:remove-bar
#:slice #:make-slice
- #:segment #:tempo #:slices #:sliceno
+ #:segment #:tempo #:tuning #:slices #:sliceno
#:make-layer-for-staff #:make-bar-for-staff
#:head #:body #:tail #:make-layer #:buffer
#:layers #:nb-layers #:layerno
@@ -168,9 +168,13 @@
(:shadowing-import-from :gsharp-buffer #:rest)
(:export #:draw-buffer #:draw-the-cursor))
+(defpackage :gsharp-tuning (:use :common-lisp :gsharp-buffer)
+ (:shadowing-import-from :gsharp-buffer #:rest #:tuning)
+ (:export #:tuning #:note-cents #:linear-tuning))
+
(defpackage :gsharp-play
- (:use :common-lisp :midi :gsharp-buffer)
- (:shadowing-import-from :gsharp-buffer #:rest)
+ (:use :common-lisp :midi :gsharp-buffer :gsharp-tuning)
+ (:shadowing-import-from :gsharp-buffer #:rest #:tuning)
(:export #:play-layer
#:play-segment
#:play-buffer))
Index: play.lisp
===================================================================
RCS file: /project/gsharp/cvsroot/gsharp/play.lisp,v
retrieving revision 1.6
diff -u -d -r1.6 play.lisp
--- play.lisp 15 Jun 2007 16:26:14 -0000 1.6
+++ play.lisp 16 Jun 2007 10:34:31 -0000
@@ -1,16 +1,15 @@
(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 (note-cents note *tuning*) 100))
-(defvar *tempo*)
+(defun cents-adjustment (note)
+ (multiple-value-bind (midi-pitch cents-adjustment)
+ (midi-pitch note)
+ cents-adjustment))
(defun measure-durations (slices)
(let ((durations (mapcar (lambda (slice)
@@ -21,16 +20,37 @@
collect (reduce #'max (mapcar #'car durations))
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 +75,8 @@
(let* ((slices (mapcar #'body (layers segment)))
(durations (measure-durations slices))
(*tempo* (tempo segment))
+ (*tuning* (or (gsharp-buffer:tuning segment)
+ (make-instance 'linear-tuning :octave-cents 1200 :fifth-cents 700)))
(tracks (loop for slice in slices
for i from 0
collect (track-from-slice slice i durations)))
@@ -85,4 +107,3 @@
(sb-ext:run-program "timidity" '("/tmp/test.mid") :search t)
#-(or cmu sbcl)
(error "write compatibility layer for RUN-PROGRAM")))
-
Index: tuning.lisp
===================================================================
RCS file: tuning.lisp
diff -N tuning.lisp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tuning.lisp 16 Jun 2007 10:34:32 -0000
@@ -0,0 +1,49 @@
+(in-package :gsharp-tuning)
+
+(defclass tuning ()
+ ())
+
+(defgeneric note-cents (note tuning))
+
+(defclass linear-tuning (tuning)
+ ((octave-cents :initform 1200 :initarg :octave-cents :accessor octave-cents)
+ (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents)))
+
+(defmethod note-cents ((note note) (tuning linear-tuning))
+ (let ((accidentals (ecase (accidentals tuning)
+ (:double-flat -2)
+ (:flat -1)
+ (:natural 0)
+ (:sharp 1)
+ (:double-sharp 2))))
+ (multiple-value-bind (octave pitch) (floor (pitch note) 7)
+ (+ (* (octave-cents tuning)
+ (+ (1+ octave)
+ (ecase pitch (0 0) (1 -1) (2 -2) (3 1) (4 0) (5 -1) (6 -2))
+ (* -5 accidentals)))
+ (* (fifth-cents tuning)
+ (+ (ecase pitch (0 0) (1 2) (2 4) (3 -1) (4 1) (5 3) (6 5))
+ (* 7 accidentals)))))))
+
+(defmethod note-cents ((note note) (tuning linear-tuning))
+ (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)))))))
+
\ No newline at end of file
cvs diff: Diffing Doc
cvs diff: Diffing Flexichain
cvs diff: Diffing Flexichain/Doc
cvs diff: Diffing Fonts
cvs diff: Diffing Obseq
cvs diff: Diffing Scores
More information about the gsharp-devel
mailing list