Index: buffer.lisp =================================================================== RCS file: /project/gsharp/cvsroot/gsharp/buffer.lisp,v retrieving revision 1.2 diff -u -r1.2 buffer.lisp --- buffer.lisp 16 Feb 2004 16:08:00 -0000 1.2 +++ buffer.lisp 22 Mar 2004 16:57:06 -0000 @@ -129,13 +129,14 @@ (staff :initarg :staff :reader staff) (head :initarg :head :reader head) (accidentals :initarg :accidentals :reader accidentals) - (dots :initarg :dots :reader dots))) + (dots :initarg :dots :reader dots) + (ties :initarg :ties :reader ties))) (defmethod print-object ((n note) stream) - (with-slots (pitch staff head accidentals dots) n + (with-slots (pitch staff head accidentals dots ties) n (format stream - "[N :pitch ~W :staff ~W :head ~W :accidentals ~W :dots ~W ] " - pitch staff head accidentals dots))) + "[N :pitch ~W :staff ~W :head ~W :accidentals ~W :dots ~W :ties ~W] " + pitch staff head accidentals dots ties))) ;;; Make a note with the pitch and staff given. ;;; @@ -167,7 +168,9 @@ (type (or integer null) dots)) (make-instance 'note :pitch pitch :staff staff - :head head :accidentals accidentals :dots dots)) + :head head :accidentals accidentals :dots dots + ;; FIXME + :ties nil)) (defun read-note-v2 (stream char n) (declare (ignore char n)) @@ -191,6 +194,24 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Tie +(defclass tie () + ((notes :initarg :notes :reader notes))) + +(defmethod print-object ((tie tie) stream) + (with-slots (notes) tie + (format stream "[~~ :notes ~W ] " notes))) + +(defun read-tie-v3 (stream char n) + (declare (ignore char n)) + (apply #'make-instance 'tie (read-delimited-list #\] stream t))) + +(set-dispatch-macro-character #\[ #\~ + #'read-tie-v3 + *gsharp-readtable-v3*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Element ;;; Return the bar to which the element belongs, or nil of the element Index: cursor.lisp =================================================================== RCS file: /project/gsharp/cvsroot/gsharp/cursor.lisp,v retrieving revision 1.1.1.1 diff -u -r1.1.1.1 cursor.lisp --- cursor.lisp 16 Feb 2004 15:46:11 -0000 1.1.1.1 +++ cursor.lisp 22 Mar 2004 16:57:06 -0000 @@ -206,11 +206,11 @@ (defgeneric backward-slice (cursor)) -(defgeneric head-slisce (cursor)) +(defgeneric head-slice (cursor)) -(defgeneric body-slisce (cursor)) +(defgeneric body-slice (cursor)) -(defgeneric tail-slisce (cursor)) +(defgeneric tail-slice (cursor)) (defgeneric insert-bar-before (bar cursor)) Index: drawing.lisp =================================================================== RCS file: /project/gsharp/cvsroot/gsharp/drawing.lisp,v retrieving revision 1.4 diff -u -r1.4 drawing.lisp --- drawing.lisp 20 Feb 2004 08:39:03 -0000 1.4 +++ drawing.lisp 22 Mar 2004 16:57:06 -0000 @@ -402,6 +402,19 @@ (defun draw-note (pane note notehead nb-dots x pos) (with-vertical-score-position (pane (staff-yoffset (staff note))) (draw-notehead pane notehead x pos) + ;; FIXME: this might be better as its own DRAW-TIES function + (dolist (tie (ties note)) + (when (eq note (cdr (notes tie))) + (let ((ox (final-xposition (car (notes tie))))) + (if (eq (final-stem-direction (cluster note)) :up) + ;; FIXME: POS is clearly not the right thing to get at + ;; the notehead position. What is? + (progn + (draw-line* pane x (staff-step (1- pos)) (/ (+ x ox) 2) (staff-step (- pos 2)) :line-thickness 2) + (draw-line* pane (/ (+ x ox) 2) (staff-step (- pos 2)) ox (staff-step (1- pos)) :line-thickness 2)) + (progn + (draw-line* pane x (staff-step (1+ pos)) (/ (+ x ox) 2) (staff-step (+ pos 2)) :line-thickness 2) + (draw-line* pane (/ (+ x ox) 2) (staff-step (+ pos 2)) ox (staff-step (1+ pos)) :line-thickness 2)))))) (when (final-accidental note) (draw-accidental pane (final-accidental note) (accidental-position note) pos)) (draw-dots pane nb-dots x pos))) Index: gui.lisp =================================================================== RCS file: /project/gsharp/cvsroot/gsharp/gui.lisp,v retrieving revision 1.8 diff -u -r1.8 gui.lisp --- gui.lisp 27 Feb 2004 09:34:30 -0000 1.8 +++ gui.lisp 22 Mar 2004 16:57:07 -0000 @@ -35,6 +40,7 @@ (add-command '(#\a) 'com-insert-note-a *global-command-table*) (add-command '(#\b) 'com-insert-note-b *global-command-table*) (add-command '(#\,) 'com-insert-rest *global-command-table*) +(add-command '(#\t) 'com-toggle-tie-backwards *global-command-table*) (add-command '(#\Space) 'com-insert-empty-cluster *global-command-table*) (add-command '(#\C :shift) 'com-add-note-c *global-command-table*) (add-command '(#\D :shift) 'com-add-note-d *global-command-table*) @@ -541,18 +579,24 @@ (defun events-from-element (element time channel) (when (typep element 'cluster) - (append (mapcar (lambda (note) - (make-instance 'note-on-message - :time time - :status (+ #x90 channel) - :key (midi-pitch note) :velocity 100)) + (append (mapcan (lambda (note) + ;; FIND ... = NOTE-ENDS-TIE-P + (unless (find note (ties note) :test #'eq :key (lambda (x) (cdr (notes x)))) + (list + (make-instance 'note-on-message + :time time + :status (+ #x90 channel) + :key (midi-pitch note) :velocity 100)))) (notes element)) - (mapcar (lambda (note) - (make-instance 'note-off-message - :time (+ time (* 128 (element-duration element))) - :status (+ #x80 channel) - :key (midi-pitch note) :velocity 100)) - (notes element))))) + (mapcan (lambda (note) + ;; NOTE-STARTS-TIE-P + (unless (find note (ties note) :test #'eq :key (lambda (x) (car (notes x)))) + (list + (make-instance 'note-off-message + :time (+ time (* 128 (element-duration element))) + :status (+ #x80 channel) + :key (midi-pitch note) :velocity 100)))) + (notes element))))) (defun events-from-bar (bar time channel) (mapcan (lambda (element) @@ -697,6 +741,88 @@ (define-gsharp-command com-insert-empty-cluster () (insert-cluster)) + +(defun find-cluster-with-note-backwards (pitch) + (let ((cursor (make-cursor (bar (cursor *gsharp-frame*)) (gsharp-cursor::pos (cursor *gsharp-frame*))))) + (do () + ((progn (backward-element cursor) + (handler-case + (and (typep (current-element cursor) 'cluster) + (find-note (current-element cursor) (make-note pitch))) + (not-on-an-element () nil))) + (prog1 (current-element cursor) + (gsharp-cursor::unset-cursor cursor)))))) + +(define-gsharp-command com-toggle-tie-backwards () + (let ((this (cur-note))) + (let ((tie (find this (ties this) :test #'eq + :key (lambda (x) (cdr (notes x)))))) + (if tie + (let* ((other (car (notes tie))) + (ocluster (cluster other))) + (let ((new-this (make-note (pitch this) + (staff this) + (head this) + (accidentals this) + (dots this))) + (new-other (make-note (pitch other) + (staff other) + (head other) + (accidentals other) + (dots other)))) + (setf (slot-value new-this 'ties) + (mapcar (lambda (tie) + (if (eq this (car (notes tie))) + (setf (car (notes tie)) new-this) + (setf (cdr (notes tie)) new-this)) + tie) + (remove tie (slot-value this 'ties) :test #'eq))) + (setf (slot-value new-other 'ties) + (mapcar (lambda (tie) + (if (eq other (car (notes tie))) + (setf (car (notes tie)) new-other) + (setf (cdr (notes tie)) new-other)) + tie) + (remove tie (slot-value other 'ties) :test #'eq))) + (remove-note this) + (remove-note other) + (add-note (cur-cluster) new-this) + (add-note ocluster new-other))) + (let* ((ocluster (find-cluster-with-note-backwards (pitch this))) + (other (find-note ocluster this))) + (let ((new-this (make-note (pitch this) + (staff this) + (head this) + (accidentals this) + (dots this))) + (new-other (make-note (pitch other) + (staff other) + (head other) + (accidentals other) + (dots other)))) + (let ((tie (make-instance 'tie :notes (cons new-other new-this)))) + (setf (slot-value new-this 'ties) + (cons tie + (mapcar (lambda (tie) + (if (eq this (car (notes tie))) + ;; FIXME: ASSERT stuff here + (setf (car (notes tie)) new-this) + (setf (cdr (notes tie)) new-this)) + tie) + (slot-value this 'ties)))) + (setf (slot-value new-other 'ties) + (cons tie + (mapcar (lambda (tie) + (if (eq other (car (notes tie))) + ;; see above + (setf (car (notes tie)) new-other) + (setf (cdr (notes tie)) new-other)) + tie) + (slot-value other 'ties)))) + (remove-note this) + (remove-note other) + (add-note (cur-cluster) new-this) + (add-note ocluster new-other)))))))) (defun cur-cluster () (current-cluster (cursor *gsharp-frame*))) Index: packages.lisp =================================================================== RCS file: /project/gsharp/cvsroot/gsharp/packages.lisp,v retrieving revision 1.2 diff -u -r1.2 packages.lisp --- packages.lisp 16 Feb 2004 16:08:00 -0000 1.2 +++ packages.lisp 22 Mar 2004 16:57:07 -0000 @@ -34,11 +34,11 @@ (defpackage :gsharp-buffer (:use :common-lisp :gsharp-utilities) - (:export #:clef #:make-clef #:name #:lineno + (:export #:tie #:ties #:clef #:make-clef #:name #:lineno #:staff #:make-staff #:gsharp-condition #:pitch #:accidentals #:dots #:cluster #:note #:make-note #:note-less #:note-equal #:bar - #:notehead #:rbeams #:lbeams #:dots #:element #:notes + #:notehead #:rbeams #:lbeams #:dots #:element #:notes #:lyrics #:add-note #:find-note #:remove-note #:cluster #:make-cluster #:rest #:make-rest #:slice #:elements #:nb-elements #:elementno #:add-element