gsharp-cvs

gsharp-cvs@common-lisp.net

396 discussions

[gsharp-cvs] CVS gsharp/Doc
by rstrandh 30 Jun '07

30 Jun '07

Update of /project/gsharp/cvsroot/gsharp/Doc In directory clnet:/tmp/cvs-serv8726 Modified Files: accidentals.tex Log Message: Fixed some unfortunate choice of wording. --- /project/gsharp/cvsroot/gsharp/Doc/accidentals.tex 2004/02/16 15:46:22 1.1.1.1 +++ /project/gsharp/cvsroot/gsharp/Doc/accidentals.tex 2007/06/30 14:15:26 1.2 @@ -3,14 +3,14 @@ The rules of Ross essentially boil down to the following: \begin{itemize} -\item If there are no suspended notes with accidentals on the right - side of the stem, place all the accidentals in the order of the +\item If there are no suspended notes on the right side of the stem + that have accidentals, place all the accidentals in the order of the topmost one that can be placed closest to the stem. -\item If there are suspended notes with accidentals on the right side - of the stem (stem is up and there is an interval of a second), start - by placing the accidental of the topmost suspended note with an - accidental as close as possible to the stem, then place the other - notes according to the previous rule. +\item If there is at least one suspended note on the right side of the + stem (stem is up and there is an interval of a second) with an + accidental, start by placing the accidental of the topmost suspended + note with an accidental as close as possible to the stem, then place + the other notes according to the previous rule. \end{itemize} To implement this algorithm, we keep a table of smallest distances

1 0

[gsharp-cvs] CVS gsharp
by mjonsson 28 Jun '07

28 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv14891 Modified Files: modes.lisp Log Message: mcclim bug workaround in key bindings for microsharper/microflatter --- /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/28 13:56:53 1.25 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/28 14:36:14 1.26 @@ -84,8 +84,10 @@ (set-key 'com-sharper 'cluster-table '((#\#))) (set-key 'com-flatter 'cluster-table '(#\@)) -(set-key 'com-microsharper 'cluster-table '((#\# :control :shift))) -(set-key 'com-microflatter 'cluster-table '((#\@ :control :shift))) +(set-key 'com-microsharper 'cluster-table '((#\# :control))) +(set-key 'com-microsharper 'cluster-table '((#\# :control :shift))) ;; mcclim bug workaround +(set-key 'com-microflatter 'cluster-table '((#\@ :control))) +(set-key 'com-microflatter 'cluster-table '((#\@ :control :shift))) ;; mcclim bug workaround (set-key 'com-add-note-c 'cluster-table '(#\C)) (set-key 'com-add-note-d 'cluster-table '(#\D)) (set-key 'com-add-note-e 'cluster-table '(#\E))

1 0

[gsharp-cvs] CVS gsharp
by mjonsson 28 Jun '07

28 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv27753 Modified Files: buffer.lisp gui.lisp modes.lisp Log Message: Completed implementation of quartertone playback for regular temperaments. Fixed keybinding bug for microsharper. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/21 11:14:25 1.47 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/28 13:56:53 1.48 @@ -317,35 +317,44 @@ ;;; 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? - ) + (fifth-cents :initform 700 :initarg :fifth-cents :accessor fifth-cents) + (quartertone-cents :initform 50 :initarg :quartertone-cents :accessor quartertone-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))))))) + (let ((octaves 1) + (fifths 0) + (sharps 0) ;; short for 7 fifths up and 4 octaves down + (quartertones 0)) + (incf octaves (floor (pitch note) 7)) + (ecase (mod (pitch note) 7) + (0 (progn)) + (1 (progn (incf octaves -1) (incf fifths 2))) + (2 (progn (incf octaves -2) (incf fifths 4))) + (3 (progn (incf octaves 1) (incf fifths -1))) + (4 (progn (incf fifths 1))) + (5 (progn (incf octaves -1) (incf fifths 3))) + (6 (progn (incf octaves -2) (incf fifths 5)))) + (ecase (accidentals note) + (:double-flat (incf sharps -2)) + (:sesquiflat (incf sharps -1) (incf quartertones -1)) + (:flat (incf sharps -1)) + (:semiflat (incf quartertones -1)) + (:natural) + (:semisharp (incf quartertones 1)) + (:sharp (incf sharps 1)) + (:sesquisharp (incf sharps 1) (incf quartertones 1)) + (:double-sharp (incf sharps 2))) + (incf octaves (* -4 sharps)) + (incf fifths (* 7 sharps)) + (+ (* octaves (octave-cents tuning)) + (* fifths (fifth-cents tuning)) + (* quartertones (quartertone-cents tuning))))) ;;; TODO: (defclass irregular-temperament ...) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/21 11:14:25 1.78 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/28 13:56:53 1.79 @@ -366,12 +366,14 @@ (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")) + (fifth-cents 'cl:number :prompt "Fifth size in cents") + (quartertone-cents 'cl:number :prompt "Quartertone 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)))) + :fifth-cents fifth-cents + :quartertone-cents quartertone-cents)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/21 11:14:27 1.24 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/28 13:56:53 1.25 @@ -84,7 +84,7 @@ (set-key 'com-sharper 'cluster-table '((#\#))) (set-key 'com-flatter 'cluster-table '(#\@)) -(set-key 'com-microsharper 'cluster-table '((#\# :control))) +(set-key 'com-microsharper 'cluster-table '((#\# :control :shift))) (set-key 'com-microflatter 'cluster-table '((#\@ :control :shift))) (set-key 'com-add-note-c 'cluster-table '(#\C)) (set-key 'com-add-note-d 'cluster-table '(#\D))

1 0

[gsharp-cvs] CVS gsharp
by mjonsson 28 Jun '07

28 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv6037 Modified Files: play.lisp Log Message: Fixed redundancies in play.lisp pointed out by Stas Boukarev --- /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/19 10:01:37 1.8 +++ /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/28 12:58:17 1.9 @@ -1,5 +1,9 @@ (in-package :gsharp-play) +(defparameter *midi-temp-file* "/tmp/timidity.mid") +(defparameter *midi-player* "timidity") +(defparameter *midi-player-arguments* '()) + (defvar *tuning*) (defvar *tempo*) @@ -73,6 +77,28 @@ (incf time (* *tempo* duration)))) (bars slice) durations)))) +(defun play-tracks (tracks) + (let ((midifile (make-instance 'midifile + :format 1 + :division 25 + :tracks tracks))) + (write-midi-file midifile *midi-temp-file*) + #+cmu + (ext:run-program *midi-player* + (append *midi-player-arguments* + (list *midi-temp-file*))) + #+sbcl + (sb-ext:run-program *midi-player* + (append *midi-player-arguments* + (list *midi-temp-file*)) + :search t) + #+clisp + (ext:run-program *midi-player* + :arguments (append *midi-player-arguments* + (list *midi-temp-file*))) + #-(or cmu sbcl clisp) + (error "write compatibility layer for RUN-PROGRAM"))) + (defun play-segment (segment) (let* ((slices (mapcar #'body (layers segment))) (durations (measure-durations slices)) @@ -80,31 +106,13 @@ (*tuning* (gsharp-buffer:tuning segment)) (tracks (loop for slice in slices for i from 0 - collect (track-from-slice slice i durations))) - (midifile (make-instance 'midifile - :format 1 - :division 25 - :tracks tracks))) - (write-midi-file midifile "/tmp/test.mid") - #+cmu - (ext:run-program "timidity" '("/tmp/test.mid")) - #+sbcl - (sb-ext:run-program "timidity" '("/tmp/test.mid") :search t) - #-(or cmu sbcl) - (error "write compatibility layer for RUN-PROGRAM"))) + collect (track-from-slice slice i durations)))) + (play-tracks tracks))) (defun play-layer (layer) (let* ((slice (body layer)) (durations (measure-durations (list slice))) - (tracks (list (track-from-slice slice 0 durations))) - (midifile (make-instance 'midifile - :format 1 - :division 25 - :tracks tracks))) - (write-midi-file midifile "/tmp/test.mid") - #+cmu - (ext:run-program "timidity" '("/tmp/test.mid")) - #+sbcl - (sb-ext:run-program "timidity" '("/tmp/test.mid") :search t) - #-(or cmu sbcl) - (error "write compatibility layer for RUN-PROGRAM"))) + (*tempo* (tempo (segment layer))) + (*tuning* (gsharp-buffer:tuning (segment layer))) + (tracks (list (track-from-slice slice 0 durations)))) + (play-tracks tracks))) \ No newline at end of file

1 0

[gsharp-cvs] CVS gsharp
by crhodes 21 Jun '07

21 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv28358 Modified Files: buffer.lisp gui.lisp measure.lisp modes.lisp sdl.lisp Log Message: Support for semi/sesqui sharp/flat. * don't declare the type of the accidentals slot any more; we can put that back in a little, after we work out a declarative way of defining all properties of accidentals. * microsharpen and microflatten commands and functions; define sharpen and flatten in terms of those (and knowing which accidentals are the tonal ones). Keybindings for the commands. * a more declarative table-based system for kerning accidentals, along with the ability to specify a per-glyph default (and a default default). Choose a sensible default default; also alter the :sharp/:sharp table when +4 steps away, as the previous value was colliding a little too much. * support for playing the semi accidentals in equal temperament. No support in linear temperament, as I don't know what they mean. * glyphs defined with a little too much liberal cut'n'paste. Some FIXMEs note the essential differences between the related glyphs. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/18 15:18:17 1.46 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/21 11:14:25 1.47 @@ -219,8 +219,10 @@ (head :initform nil :initarg :head :reader head :type (or (member :whole :half :filled) null)) (accidentals :initform :natural :initarg :accidentals :reader accidentals - :type (member :natural :flat :double-flat - :sharp :double-sharp)) + ;; FIXME: we want :TYPE ACCIDENTAL here but need to + ;; sort out order of definition for that to be useful. + #+nil #+nil + :type (member :natural :flat :double-flat :sharp :double-sharp)) (dots :initform nil :initarg :dots :reader dots :type (or (integer 0 3) null)) (%tie-right :initform nil :initarg :tie-right :accessor tie-right) @@ -230,8 +232,9 @@ (declare (type (integer 0 127) pitch) (type staff staff) (type (or (member :whole :half :filled) null) head) - (type (member :natural :flat :double-flat - :sharp :double-sharp) + ;; FIXME: :TYPE ACCIDENTAL + #+nil #+nil + (type (member :natural :flat :double-flat :sharp :double-sharp) accidentals) (type (or (integer 0 3) null) dots) (ignore head accidentals dots)) @@ -300,9 +303,13 @@ (ecase pitch (0 0) (1 200) (2 400) (3 500) (4 700) (5 900) (6 1100)) (ecase (accidentals note) (:double-flat -200) + (:sesquiflat -150) (:flat -100) + (:semiflat -50) (:natural 0) + (:semisharp 50) (:sharp 100) + (:sesquisharp 150) (:double-sharp 200))))) ;;; regular temperaments are temperaments that --- /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/18 15:18:17 1.77 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/21 11:14:25 1.78 @@ -822,17 +822,61 @@ (add-note element new-note) (setf *current-note* new-note)))) +(defmacro define-microtonal-accidentals (&rest microaccidentals) + `(progn + (setf (symbol-plist 'microsharpen) + ',(loop for (a b) on microaccidentals + if b collect a and collect b + else collect a and collect a)) + (setf (symbol-plist 'microflatten) + ',(loop for (a b) on (reverse microaccidentals) + if b collect a and collect b + else collect a and collect a)) + (deftype accidental () '(member ,@microaccidentals)) + (defun microsharpen (accidental) + (or (getf (symbol-plist 'microsharpen) accidental) + (error 'type-error :datum accidental :expected-type 'microaccidental))) + (defun microflatten (accidental) + (or (getf (symbol-plist 'microflatten) accidental) + (error 'type-error :datum accidental :expected-type 'microaccidental))))) + +(defmacro define-accidentals (&rest accidentals) + `(progn + (deftype accidental () '(member ,@accidentals)) + (defun sharpen (accidental) + (do ((a (microsharpen accidental) (microsharpen a)) + (olda accidental a)) + ((or (eq a olda) (member a ',accidentals)) a))) + (defun flatten (accidental) + (do ((a (microflatten accidental) (microflatten a)) + (olda accidental a)) + ((or (eq a olda) (member a ',accidentals)) a))))) + +(define-microtonal-accidentals :double-flat :sesquiflat :flat :semiflat + :natural + :semisharp :sharp :sesquisharp :double-sharp) + +(define-accidentals :double-flat :flat :natural :sharp :double-sharp) + (define-gsharp-command com-sharper () (let* ((cluster (cur-cluster)) (note (cur-note)) (new-note (make-note (pitch note) (staff note) :head (head note) - :accidentals (ecase (accidentals note) - (:double-sharp :double-sharp) - (:sharp :double-sharp) - (:natural :sharp) - (:flat :natural) - (:double-flat :flat)) + :accidentals (sharpen (accidentals note)) + :dots (dots note)))) + (remove-note note) + (add-note cluster new-note) + (setf *current-note* new-note))) + +(define-gsharp-command com-microsharper () + ;; FIXME: what are CUR-CLUSTER and CUR-NOTE and how do they relate + ;; to CURRENT-CLUSTER &c? + (let* ((cluster (cur-cluster)) + (note (cur-note)) + (new-note (make-note (pitch note) (staff note) + :head (head note) + :accidentals (microsharpen (accidentals note)) :dots (dots note)))) (remove-note note) (add-note cluster new-note) @@ -843,12 +887,18 @@ (note (cur-note)) (new-note (make-note (pitch note) (staff note) :head (head note) - :accidentals (ecase (accidentals note) - (:double-sharp :sharp) - (:sharp :natural) - (:natural :flat) - (:flat :double-flat) - (:double-flat :double-flat)) + :accidentals (flatten (accidentals note)) + :dots (dots note)))) + (remove-note note) + (add-note cluster new-note) + (setf *current-note* new-note))) + +(define-gsharp-command com-microflatter () + (let* ((cluster (cur-cluster)) + (note (cur-note)) + (new-note (make-note (pitch note) (staff note) + :head (head note) + :accidentals (microflatten (accidentals note)) :dots (dots note)))) (remove-note note) (add-note cluster new-note) --- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/06/21 16:31:54 1.32 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2007/06/21 11:14:25 1.33 @@ -248,48 +248,57 @@ nil (accidentals note))))) -;;; table of x offsets (in staff steps) of accendentals. -;;; The first index represents a notehead or a type of accidental. -;;; The second index represents a type of accidentsl. -;;; The third index is a vertical distance, measured in difference -;;; in staff steps between the two. -;;; The table entry gives how much the accidental represented by -;;; the second parameter must be positioned to the left of the -;;; first one. -;;; Entries in the table are offset by 5 in the last dimension -;;; so that vertical distances between -5 and 5 can be represented -(defparameter *accidental-offset* - ;;; -5 -4 -3 -2 -1 0 1 2 3 4 5 - #3A((( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - dbl flat - ( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) ; notehead - flat - ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - natural - ( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) ; notehead - sharp - ( 0 0 0 3.5 3.5 3.5 3.5 3.5 0 0 0)) ; notehead - dbl sharp - (( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - dbl flat - ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - flat - ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) ; dbl flat - natural - ( 4 4 4 4 4 4 4 4 4 3.5 0) ; dbl flat - sharp - ( 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 0 0 0)) ; dbl flat - dbl sharp - (( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - dbl flat - ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - flat - ( 2 2 2 2 2 2 2 2 1.5 1 0) ; flat - natural - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 1.5 0) ; flat - sharp - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0 0)) ; flat - dbl sharp - (( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - dbl flat - ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - flat - ( 2 2 2 2 2 2 2 2 2 1.5 1.5) ; natural - natural - ( 2 2 2 2 2 2 2 2 2 2 2) ; natural - sharp - ( 2 2 2 2 2 2 2 2 1 1 1)) ; natural - dbl sharp - (( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - dbl flat - ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - flat - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) ; sharp - natural - ( 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 2.0) ; sharp - sharp - ( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0)) ; sharp - dbl sharp - (( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - dbl flat - ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - flat - ( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) ; dbl sharp - natural - ( 0 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 0) ; dbl sharp - sharp - ( 0 0 0 2.8 2.8 2.8 2.8 2.8 0 0 0)))) ; dbl sharp - dbl sharp +(defmacro define-accidental-kerning (left right table) + `(let ((plist (getf (symbol-plist 'accidental-kerning) ',right))) + (setf (getf (symbol-plist 'accidental-kerning) ',right) + (cons (cons ',left ',table) + (remove ',left plist :key #'car))))) +(defmacro define-default-accidental-kerning (right table) + `(define-accidental-kerning default ,right ,table)) + +(macrolet ((define-kernings (&rest args) + `(progn ,@(loop for (left right table) on args by #'cdddr + collect `(define-accidental-kerning ,left ,right ,table))))) + (define-kernings + :double-flat :notehead #( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) + :flat :notehead #( 0 0 0 3.5 3.5 3.5 3.5 3.5 3.5 1 0) + :natural :notehead #( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) + :sharp :notehead #( 0 3.5 3.5 3.5 3.5 3.5 3.5 3.5 1 1 0) + :double-sharp :notehead #( 0 0 0 3.5 3.5 3.5 3.5 3.5 0 0 0) + + :double-flat :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) + :flat :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) + :natural :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 3 3 0) + :sharp :double-flat #( 4 4 4 4 4 4 4 4 4 3.5 0) + :double-sharp :double-flat #(3.8 3.8 3.8 3.8 3.8 3.8 3.8 3.8 0 0 0) + + :double-flat :flat #( 2 2 2 2 2 2 2 2 1.5 1 0) + :flat :flat #( 2 2 2 2 2 2 2 2 1.5 1 0) + :natural :flat #( 2 2 2 2 2 2 2 2 1.5 1 0) + :sharp :flat #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 1.5 0) + :double-sharp :flat #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0 0) + + :double-flat :natural #( 2 2 2 2 2 2 2 2 2 1.5 1.5) + :flat :natural #( 2 2 2 2 2 2 2 2 2 1.5 1.5) + :natural :natural #( 2 2 2 2 2 2 2 2 2 1.5 1.5) + :sharp :natural #( 2 2 2 2 2 2 2 2 2 2 2) + :double-sharp :natural #( 2 2 2 2 2 2 2 2 1 1 1) + + :double-flat :sharp #( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) + :flat :sharp #( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) + :natural :sharp #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0 1.5 1.0) + :sharp :sharp #(2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.0) + :double-sharp :sharp #( 0 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 0 0) + + :double-flat :double-sharp #( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) + :flat :double-sharp #( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) + :natural :double-sharp #( 0 0 2.4 2.4 2.4 2.4 2.4 2.4 2 1 0) + :sharp :double-sharp #( 0 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 2.8 0) + :double-sharp :double-sharp #( 0 0 0 2.8 2.8 2.8 2.8 2.8 0 0 0) + )) + +(defvar *default-accidental-kerning* + #(4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0 4.0)) ;;; given 1) a type of accidental 2) its position (in staff steps) 3) ;;; a type of accidental or a type of notehead, and 4) its position, @@ -297,24 +306,16 @@ ;;; steps to the left that it must be moved in order to avoid overlap ;;; with the second one. (defun accidental-distance (acc1 pos1 acc2 pos2) - (let ((dist (- pos2 pos1))) - (if (> (abs dist) 5) - 0 - (aref *accidental-offset* - (ecase acc2 - (:notehead 0) - (:double-flat 1) - (:flat 2) - (:natural 3) - (:sharp 4) - (:double-sharp 5)) - (ecase acc1 - (:double-flat 0) - (:flat 1) - (:natural 2) - (:sharp 3) - (:double-sharp 4)) - (+ dist 5))))) + (let* ((dist (- pos2 pos1)) + (right-info (getf (symbol-plist 'accidental-kerning) acc2)) + (left-right-info (cdr (assoc acc1 right-info))) + (default-right-info (cdr (assoc 'default right-info)))) + (cond + ((> (abs dist) 5) 0) + ((or (not right-info) (and (not left-right-info) (not default-right-info))) + (aref *default-accidental-kerning* (+ dist 5))) + ((not left-right-info) (aref default-right-info (+ dist 5))) + (t (aref left-right-info (+ dist 5)))))) ;;; given two notes (where the first one has an accidental, and the ;;; second one may or may not have an accidental) and the conversion --- /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/10 08:15:29 1.23 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/21 11:14:27 1.24 @@ -84,6 +84,8 @@ (set-key 'com-sharper 'cluster-table '((#\#))) (set-key 'com-flatter 'cluster-table '(#\@)) +(set-key 'com-microsharper 'cluster-table '((#\# :control))) +(set-key 'com-microflatter 'cluster-table '((#\@ :control :shift))) (set-key 'com-add-note-c 'cluster-table '(#\C)) (set-key 'com-add-note-d 'cluster-table '(#\D)) (set-key 'com-add-note-e 'cluster-table '(#\E)) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 22:40:26 1.31 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2007/06/21 11:14:27 1.32 @@ -1009,6 +1009,56 @@ ;;; ;;; Accidentals +(defmethod compute-design ((font font) (shape (eql :semisharp))) + (with-slots ((sld staff-line-distance) + (slt staff-line-thickness) + stem-thickness + yoffset) font + (let* (;; A factor that determines the space between the vertical + ;; bars and the outer edge of the character as a fraction of + ;; the staff line distance + (edge-distance-multiplier 0.2) + ;; A factor that determines the height of the thin part as a + ;; fraction of the staff line distance + (height-multiplier 2.5) + ;; A factor that determines the width of the hole as a fraction of the + ;; staff line distance. + (hole-width-multiplier 0.33) + (hole-width (round (* hole-width-multiplier sld))) + ;; Hope that half a pixel will not be visible and will not influence + ;; the required distance to the noteheads. + ;; + ;; FIXME: this is the only real difference between the + ;; :semisharp and :sesquisharp glyph calculations, and the + ;; :sharp glyph. Find a way to unify the glyph + ;; computations in a proper metafonty way. + (xoffset (if (oddp hole-width) 0.5 0.5)) + (edge-distance (* edge-distance-multiplier sld)) + (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance))) + ;; FIXME: this leads to a blurry glyph at most sizes: + ;; choose a coordinate which lies on a pixel boundary in + ;; preference. + (xleft (* -0.25 width)) + (xright (- xleft)) + (yleft (* -0.15 width)) + (yright (- yleft)) + ;; The path for the thick part symmetric around (0, 0) + (thickpart (mf (complex xleft yleft) -- (complex xright yright))) + ;; Determine the y coordinate of the previous path at the + ;; cross point of the thin part. Use congruent triangles. + (ythin (/ (* (- xright edge-distance) yright) xright)) + (height (* height-multiplier sld)) + ;; The path for the thin part symmetric around (0, 0) + (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height))))) + (clim:region-union + (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2)) + (clim:region-union (draw-path (translate thickpart + (complex xoffset (+ yoffset (* 0.5 sld))))) + (draw-path (translate thickpart + (complex xoffset (+ yoffset (* -0.5 sld))))))) + (with-pen (scale +razor+ stem-thickness) + (draw-path (translate thinpart (complex xoffset yoffset)))))))) + (defmethod compute-design ((font font) (shape (eql :sharp))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness) @@ -1060,6 +1110,58 @@ (* 0.5 stem-thickness)) (+ yoffset ythin)))))))))) +(defmethod compute-design ((font font) (shape (eql :sesquisharp))) + (with-slots ((sld staff-line-distance) + (slt staff-line-thickness) + stem-thickness + yoffset) font + (let* (;; A factor that determines the space between the vertical + ;; bars and the outer edge of the character as a fraction of + ;; the staff line distance + (edge-distance-multiplier 0.2) + ;; A factor that determines the height of the thin part as a + ;; fraction of the staff line distance + (height-multiplier 2.5) + ;; A factor that determines the width of the hole as a fraction of the + ;; staff line distance. + (hole-width-multiplier 0.33) + (hole-width (round (* hole-width-multiplier sld))) + ;; Hope that half a pixel will not be visible and will not + ;; influence the required distance to the noteheads. + ;; + ;; FIXME: see note in :semisharp glyph at this point + (xoffset (if (oddp hole-width) 0.5 0.5)) + (edge-distance (* edge-distance-multiplier sld)) + (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance))) + (xleft (* -0.75 width)) + (xright (- xleft)) + (yleft (* -0.15 width)) + (yright (- yleft)) + ;; The path for the thick part symmetric around (0, 0) + (thickpart (mf (complex xleft yleft) -- (complex xright yright))) + ;; Determine the y coordinate of the previous path at the + ;; cross point of the thin part. Use congruent triangles. + (ythin (/ (* (- xright edge-distance) yright) xright)) + (height (* height-multiplier sld)) + ;; The path for the thin part symmetric around (0, 0) + (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height))))) + (clim:region-union + (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2)) + (clim:region-union (draw-path (translate thickpart + (complex xoffset (+ yoffset (* 0.5 sld))))) + (draw-path (translate thickpart + (complex xoffset (+ yoffset (* -0.5 sld))))))) + (with-pen (scale +razor+ stem-thickness) + (clim:region-union + (clim:region-union + (draw-path (translate thinpart + (complex (- xoffset hole-width (* 1 stem-thickness)) + (- yoffset ythin)))) + (draw-path (translate thinpart (complex (- xoffset (* 0 stem-thickness)) yoffset)))) + (draw-path (translate thinpart + (complex (+ xoffset hole-width (* 1 stem-thickness)) + (+ yoffset ythin)))))))))) + (defmethod compute-design ((font font) (shape (eql :double-sharp))) (with-slots ((sld staff-line-distance) xoffset yoffset) font (flet ((c (x y) (complex x y))) @@ -1075,13 +1177,38 @@ (translate (rotate leg (* pi 1.0)) (c xoffset yoffset)) (translate (rotate leg (* pi 1.5)) (c xoffset yoffset)))))))) +(defmethod compute-design ((font font) (shape (eql :semiflat))) + (with-slots ((sld staff-line-distance) stem-thickness) font + (flet ((c (x y) (complex x y))) + (let* ((outer (xyscale (translate (rotate +half-circle+ pi) #c(-0.5 0)) + (* 1 sld) (* 1 sld))) + ;; FIXME: 1.2 here (and in the :sesquiflat glyph, below) + ;; represents the difference in width between the + ;; :semiflat bulge and the regular :flat bulge. Find a + ;; way to share code between the glyphs. + (inner (xyscale (translate (rotate +half-circle+ pi) #c(-0.6 0)) + (* 0.75 sld) (* (/ 0.75 1.2) sld))) + (middle (mf (climi::path-end outer) -- (climi::path-end inner))) + (finish (mf (climi::path-start inner) -- (climi::path-start outer))) + (combined (climi::close-path + (reduce #'clim:region-union + (list outer middle (climi::reverse-path inner) finish))))) + (clim:region-union (translate (rotate (slant combined 0.6) (- (/ pi 2))) + (c (round (- (* -0.2 sld) stem-thickness)) (* -0.5 sld))) + (with-pen (scale +razor+ stem-thickness) + (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness)) + (* 1.5 sld)) + -- + (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness)) + (* -0.5 sld)))))))))) + (defmethod compute-design ((font font) (shape (eql :flat))) (with-slots ((sld staff-line-distance) stem-thickness) font (flet ((c (x y) (complex x y))) (let* ((outer (xyscale (translate +half-circle+ #c(-0.5 0)) sld (* 1.2 sld))) (inner (scale (translate +half-circle+ #c(-0.6 0)) - (* 0.8 sld))) + (* 0.75 sld))) (middle (mf (climi::path-end outer) -- (climi::path-end inner))) (finish (mf (climi::path-start inner) -- (climi::path-start outer))) (combined (climi::close-path @@ -1096,6 +1223,38 @@ (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness)) (* -0.5 sld)))))))))) +(defmethod compute-design ((font font) (shape (eql :sesquiflat))) + (with-slots ((sld staff-line-distance) stem-thickness) font + (flet ((c (x y) (complex x y))) + (let* ((outer (xyscale (translate (rotate +half-circle+ pi) #c(-0.5 0)) + (* 1 sld) (* 1 sld))) + (inner (xyscale (translate (rotate +half-circle+ pi) #c(-0.6 0)) + (* 0.75 sld) (* (/ 0.75 1.2) sld))) + (middle (mf (climi::path-end outer) -- (climi::path-end inner))) + (finish (mf (climi::path-start inner) -- (climi::path-start outer))) + (combined (climi::close-path + (reduce #'clim:region-union + (list outer middle (climi::reverse-path inner) finish)))) + (outer1 (xyscale (translate +half-circle+ #c(-0.5 0)) + sld (* 1.2 sld))) + (inner1 (scale (translate +half-circle+ #c(-0.6 0)) + (* 0.75 sld))) + (middle1 (mf (climi::path-end outer1) -- (climi::path-end inner1))) + (finish1 (mf (climi::path-start inner1) -- (climi::path-start outer1))) + (combined1 (climi::close-path + (reduce #'clim:region-union + (list outer1 middle1 (climi::reverse-path inner1) finish1))))) + (clim:region-union (clim:region-union (translate (rotate (slant combined (* 0.6 1.2)) (- (/ pi 2))) + (c (round (- (* -0.2 sld) stem-thickness)) (* -0.5 sld))) + (translate (rotate (slant combined1 -0.6) (- (/ pi 2))) + (c (round (* -0.2 sld)) (* -0.5 sld)))) + (with-pen (scale +razor+ stem-thickness) + (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness)) + (* 1.5 sld)) + -- + (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness)) + (* -0.5 sld)))))))))) + (defmethod compute-design ((font font) (shape (eql :double-flat))) (with-slots ((sld staff-line-distance) stem-thickness) font (flet ((c (x y) (complex x y)))

1 0

[gsharp-cvs] CVS gsharp
by crhodes 19 Jun '07

19 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv6155 Modified Files: play.lisp Log Message: a above middle c is 69, not 67. --- /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/18 15:18:17 1.7 +++ /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/19 10:01:37 1.8 @@ -4,7 +4,7 @@ (defvar *tempo*) (defun midi-pitch (note) - (round (+ (+ 6700 ; a above middle c, 440 Hz + (round (+ (+ 6900 ; 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*)))

1 0

[gsharp-cvs] CVS gsharp
by mjonsson 18 Jun '07

18 Jun '07

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"))) -

1 0

[gsharp-cvs] CVS gsharp
by mjonsson 15 Jun '07

15 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv27451 Modified Files: buffer.lisp play.lisp Log Message: Changed test.mid to /tmp/test.mid in play.lisp, removed code duplication calculating durations of bars --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/06 13:16:02 1.44 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/06/15 16:26:14 1.45 @@ -646,7 +646,7 @@ ;;; kind of cache, in order to avoid looping over each ;;; element and computing the duration of each one each time. (defmethod duration ((bar bar)) - (reduce #'+ (mapcar #'duration (elements bar)))) + (reduce #'+ (elements bar) :key #'duration)) (defgeneric make-bar-for-staff (staff &rest args &key elements)) --- /project/gsharp/cvsroot/gsharp/play.lisp 2006/03/02 09:29:44 1.5 +++ /project/gsharp/cvsroot/gsharp/play.lisp 2007/06/15 16:26:14 1.6 @@ -14,9 +14,7 @@ (defun measure-durations (slices) (let ((durations (mapcar (lambda (slice) - (mapcar (lambda (bar) - (reduce #'+ (elements bar) - :key #'duration)) + (mapcar #'duration (bars slice))) slices))) (loop while durations @@ -80,11 +78,11 @@ :format 1 :division 25 :tracks tracks))) - (write-midi-file midifile "test.mid") + (write-midi-file midifile "/tmp/test.mid") #+cmu - (ext:run-program "timidity" '("test.mid")) + (ext:run-program "timidity" '("/tmp/test.mid")) #+sbcl - (sb-ext:run-program "timidity" '("test.mid") :search t) + (sb-ext:run-program "timidity" '("/tmp/test.mid") :search t) #-(or cmu sbcl) (error "write compatibility layer for RUN-PROGRAM")))

1 0

[gsharp-cvs] CVS gsharp
by crhodes 10 Jun '07

10 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv21208 Modified Files: gui.lisp modes.lisp Log Message: select-layer-by-layout commands and keybindings (C-down and C-up for now) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/07 09:26:04 1.75 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/06/10 08:15:28 1.76 @@ -1108,6 +1108,38 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; selecting layers based on layout (next/previous staff) + +;;; FIXME: numeric argument handling again +(define-gsharp-command (com-previous-staff :name t) + () + (let ((staff (car (staves (layer (current-cursor)))))) + (loop for (prev curr) on (staves (current-buffer)) + if (eq curr staff) + do (let ((layers (layers (segment (current-cursor))))) + (dolist (layer layers) + (when (member prev (staves layer)) + (select-layer (current-cursor) layer) + (do () + ((eq prev (car (staves layer)))) + (com-rotate-staves)) + (return-from com-previous-staff))))))) +(define-gsharp-command (com-next-staff :name t) + () + (let ((staff (car (staves (layer (current-cursor)))))) + (loop for (curr next) on (staves (current-buffer)) + if (eq curr staff) + do (let ((layers (layers (segment (current-cursor))))) + (dolist (layer layers) + (when (member next (staves layer)) + (select-layer (current-cursor) layer) + (do () + ((eq next (car (staves layer)))) + (com-rotate-staves)) + (return-from com-next-staff))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; delete commands (defun go-to-beginning-of-bar (cursor) --- /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/07 09:26:05 1.22 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2007/06/10 08:15:29 1.23 @@ -17,6 +17,10 @@ (set-key 'com-end-of-line 'global-gsharp-table '((#\e :control))) (set-key 'com-beginning-of-line 'global-gsharp-table '((#\a :control))) +;;; FIXME: implement numeric arg handling +(set-key 'com-previous-staff 'global-gsharp-table '((:up :control))) +(set-key 'com-next-staff 'global-gsharp-table '((:down :control))) + (set-key 'com-insert-barline 'global-gsharp-table '(#\|)) (set-key 'com-end-of-score 'global-gsharp-table '((#\> :shift :meta)))

1 0

[gsharp-cvs] CVS gsharp
by crhodes 10 Jun '07

10 Jun '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv20543 Modified Files: drawing.lisp Log Message: When drawing the gsharp cursor, also scroll the viewport if necessary so that the cursor remains on the screen. Currently this is a little ugly in UI, because of slightly nasty discontinuities in the drawing process, and pretty ugly in the code. FIXME commentaries are noted --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2007/06/07 10:21:47 1.75 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2007/06/10 08:10:03 1.76 @@ -772,35 +772,54 @@ (defun draw-the-cursor (pane cursor cursor-element last-note) (let* ((staff (car (staves (layer cursor)))) - (bar (bar cursor))) + (bar (bar cursor)) + (sy (system-y-position bar)) + (yoffset (- (gsharp-drawing::staff-yoffset staff)))) + (let ((region (pane-viewport-region pane))) + (when region + ;; FIXME: adjusting the viewport at this point leads to ugly + ;; jumps in the display when going across pages, as the page + ;; is first laid out and drawn, then the viewport is moved. + ;; If we instead cleared the pane, laid out the page, adjusted + ;; the viewport, and finally drew the page (and cursor) then + ;; that jump would probably go away. + ;; + ;; FIXME: this calculation only takes account of the centre of + ;; the cursor. Refactor this whole DRAW-THE-CURSOR function + ;; so that it's easy to take account of the vertical extent of + ;; the cursor. + (unless (< (bounding-rectangle-min-y region) + (- sy yoffset) + (bounding-rectangle-max-y region)) + (let ((maxy (- (bounding-rectangle-max-y pane) (bounding-rectangle-height region)))) + (scroll-extent pane 0 (max 0 (min maxy + (- sy (floor (bounding-rectangle-height region) 2))))))))) + (flet ((draw-cursor (x) - (let* ((sy (system-y-position bar)) - ;; Why (- STAFF-YOFFSET)? dunno. -- CSR, 2005-10-28 - (yoffset (- (gsharp-drawing::staff-yoffset staff)))) - (if (typep staff 'fiveline-staff) - (let* ((clef (clef staff)) - (bottom-line (bottom-line clef)) - (lnote-offset (score-pane:staff-step (- last-note bottom-line)))) - (draw-line* pane - x (+ sy (- (+ (score-pane:staff-step 12) yoffset))) - x (+ sy (- (+ (score-pane:staff-step -4) yoffset))) - :ink +yellow+) - (draw-line* pane - (- x 1) (+ sy (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset))) - (- x 1) (+ sy (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset))) - :ink +red+) - (draw-line* pane - (+ x 1) (+ sy (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset))) - (+ x 1) (+ sy (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset))) - :ink +red+)) - (progn (draw-line* pane - (+ x 1) (+ sy (- (+ (score-pane:staff-step 2) yoffset))) - (+ x 1) (+ sy (- (+ (score-pane:staff-step -2) yoffset))) - :ink +red+) - (draw-line* pane - (- x 1) (+ sy (- (+ (score-pane:staff-step 2) yoffset))) - (- x 1) (+ sy (- (+ (score-pane:staff-step -2) yoffset))) - :ink +red+)))))) + (if (typep staff 'fiveline-staff) + (let* ((clef (clef staff)) + (bottom-line (bottom-line clef)) + (lnote-offset (score-pane:staff-step (- last-note bottom-line)))) + (draw-line* pane + x (+ sy (- (+ (score-pane:staff-step 12) yoffset))) + x (+ sy (- (+ (score-pane:staff-step -4) yoffset))) + :ink +yellow+) + (draw-line* pane + (- x 1) (+ sy (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset))) + (- x 1) (+ sy (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset))) + :ink +red+) + (draw-line* pane + (+ x 1) (+ sy (- (+ (score-pane:staff-step -3.4) yoffset lnote-offset))) + (+ x 1) (+ sy (- (+ (score-pane:staff-step 3.6) yoffset lnote-offset))) + :ink +red+)) + (progn (draw-line* pane + (+ x 1) (+ sy (- (+ (score-pane:staff-step 2) yoffset))) + (+ x 1) (+ sy (- (+ (score-pane:staff-step -2) yoffset))) + :ink +red+) + (draw-line* pane + (- x 1) (+ sy (- (+ (score-pane:staff-step 2) yoffset))) + (- x 1) (+ sy (- (+ (score-pane:staff-step -2) yoffset))) + :ink +red+))))) (score-pane:with-staff-size 6 (let* ((x (final-absolute-measure-xoffset bar)) (width (final-width bar))

1 0

← Newer
1
...
5
6
7
8
9
10
11
...
40
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs