Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv31201 Modified Files: buffer.lisp cursor.lisp drawing.lisp gui.lisp input-state.lisp measure.lisp numbering.lisp packages.lisp score-pane.lisp system.lisp utilities.lisp Added Files: modes.lisp sequence-dico.lisp Log Message: These current modifications are not in a good state yet. Some of them are terribly kludgy, but I do not think anything is broken. New files: modes.lisp containing key bindings sequence-dico.lisp: a dictionary that searches for objects associated with sequences (lists really). Utilities: Added some horribly kludgy Unicode support. Buffer: New types: lyrics-staff, melody-element, lyrics-element, melody-bar, lyrics-bar, melody-layer, lyrics-layer Layers are no longer ordered. Cursor: Removed functionality that used layer ordering. Gui: Removed commands that used layer ordering. Added new commands to navigate, insert, and delete layers. Factored out and improved command processing. Some menus in menu bar work better. Added new presentation methods and types. Still no support for typing lyrics, but you can see them if they are already in a .gsh file. Input state: It no longer contains the staff. Instead the current staff is the first in the list of staves in the current layer. Drawing: We can now draw lyrics. Score pane: Now has a lyrics-staff presentation type. Date: Fri Jul 23 09:51:16 2004 Author: rstrandh Index: gsharp/buffer.lisp diff -u gsharp/buffer.lisp:1.4 gsharp/buffer.lisp:1.5 --- gsharp/buffer.lisp:1.4 Sun Jul 18 23:23:53 2004 +++ gsharp/buffer.lisp Fri Jul 23 09:51:16 2004 @@ -65,7 +65,9 @@ ;;; Staff (defclass staff () - ((name :accessor name :initarg :name :initform "default"))) + ((name :accessor name :initarg :name :initform "default staff"))) + +;;; fiveline (defgeneric clef (fiveline-staff)) @@ -100,6 +102,26 @@ #'read-fiveline-staff-v3 *gsharp-readtable-v3*) +;;; lyric + +(defclass lyrics-staff (staff) + ()) + +(defmethod print-object ((s lyrics-staff) stream) + (with-slots (name) s + (format stream "[L :name ~W ] " name))) + +(defun make-lyrics-staff (name) + (make-instance 'lyrics-staff :name name)) + +(defun read-lyrics-staff-v3 (stream char n) + (declare (ignore char n)) + (apply #'make-instance 'lyrics-staff (read-delimited-list #\] stream t))) + +(set-dispatch-macro-character #\[ #\L + #'read-lyrics-staff-v3 + *gsharp-readtable-v3*) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Note @@ -243,6 +265,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Melody element + +(defclass melody-element (element) ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Cluster ;;; Return a list of the notes of the cluster @@ -261,7 +289,7 @@ ;;; to any cluster. (defgeneric remove-note (note)) -(defclass cluster (element) +(defclass cluster (melody-element) ((notes :initform '() :initarg :notes :accessor notes) (stem-direction :initarg :stem-direction :accessor stem-direction) (stem-length :initform nil :initarg :stem-length :accessor stem-length))) @@ -329,7 +357,7 @@ ;;; ;;; Rest -(defclass rest (element) +(defclass rest (melody-element) ((staff :initarg :staff :reader staff) (staff-pos :initarg :staff-pos :initform 4 :reader staff-pos))) @@ -372,6 +400,33 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Lyrics element + +(defclass lyrics-element (element) + ((staff :initarg :staff :reader staff) + (text :initarg :text + :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0) + :reader text))) + +(defun make-lyrics-element (rbeams lbeams dots notehead staff) + (make-instance 'lyrics-element + :rbeams rbeams :lbeams lbeams :dots dots + :notehead notehead :staff staff)) + +(defmethod print-object ((elem lyrics-element) stream) + (with-slots (notehead rbeams lbeams dots xoffset staff text) elem + (format stream "[A :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :staff ~W :text ~W ] " text))) + +(defun read-lyrics-element-v3 (stream char n) + (declare (ignore char n)) + (apply #'make-instance 'lyrics-element (read-delimited-list #\] stream t))) + +(set-dispatch-macro-character #\[ #\A + #'read-lyrics-element-v3 + *gsharp-readtable-v3*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Bar ;;; It is recommended that the concept of a bar be hidden from the @@ -401,37 +456,6 @@ ((slice :initform nil :initarg :slice :reader slice) (elements :initform '() :initarg :elements :reader elements))) -(defmethod print-object ((b bar) stream) - (format stream "[| :elements ~W ] " (elements b))) - -(defun make-bar () - (make-instance 'bar)) - -(defun read-bar-v2 (stream char n) - (declare (ignore char n)) - (let* ((elements (read stream nil nil t)) - (bar (make-instance 'bar :elements elements))) - (loop for element in elements do - (setf (slot-value element 'bar) bar)) - (skip-until-close-bracket stream) - bar)) - -(set-dispatch-macro-character #\[ #\| - #'read-bar-v2 - *gsharp-readtable-v2*) - -(defun read-bar-v3 (stream char n) - (declare (ignore char n)) - (let* ((rest (read-delimited-list #\] stream t)) - (bar (apply #'make-instance 'bar rest))) - (loop for element in (elements bar) do - (setf (slot-value element 'bar) bar)) - bar)) - -(set-dispatch-macro-character #\[ #\| - #'read-bar-v3 - *gsharp-readtable-v3*) - (defmethod nb-elements ((bar bar)) (length (elements bar))) @@ -465,6 +489,59 @@ (setf elements (delete element elements :test #'eq))) (setf bar nil))) +(defclass melody-bar (bar) ()) + +(defmethod print-object ((b melody-bar) stream) + (format stream "[| :elements ~W ] " (elements b))) + +(defun make-melody-bar () + (make-instance 'melody-bar)) + +(defun read-melody-bar-v2 (stream char n) + (declare (ignore char n)) + (let* ((elements (read stream nil nil t)) + (bar (make-instance 'melody-bar :elements elements))) + (loop for element in elements do + (setf (slot-value element 'bar) bar)) + (skip-until-close-bracket stream) + bar)) + +(set-dispatch-macro-character #\[ #\| + #'read-melody-bar-v2 + *gsharp-readtable-v2*) + +(defun read-melody-bar-v3 (stream char n) + (declare (ignore char n)) + (let* ((rest (read-delimited-list #\] stream t)) + (bar (apply #'make-instance 'melody-bar rest))) + (loop for element in (elements bar) do + (setf (slot-value element 'bar) bar)) + bar)) + +(set-dispatch-macro-character #\[ #\| + #'read-melody-bar-v3 + *gsharp-readtable-v3*) + +(defclass lyrics-bar (bar) ()) + +(defmethod print-object ((b lyrics-bar) stream) + (format stream "[C :elements ~W ] " (elements b))) + +(defun make-lyrics-bar () + (make-instance 'lyrics-bar)) + +(defun read-lyrics-bar-v3 (stream char n) + (declare (ignore char n)) + (let* ((rest (read-delimited-list #\] stream t)) + (bar (apply #'make-instance 'lyrics-bar rest))) + (loop for element in (elements bar) do + (setf (slot-value element 'bar) bar)) + bar)) + +(set-dispatch-macro-character #\[ #\C + #'read-lyrics-bar-v3 + *gsharp-readtable-v3*) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Slice @@ -497,11 +574,6 @@ (defun make-empty-slice () (make-instance 'slice)) -(defun make-initialized-slice () - (let ((slice (make-empty-slice))) - (add-bar (make-bar) slice 0) - slice)) - (defun read-slice-v2 (stream char n) (declare (ignore char n)) (let* ((bars (read stream nil nil t)) @@ -552,14 +624,24 @@ (declare (ignore condition)) (format stream "Attempt to delete a bar not in a slice")))) -(defmethod remove-bar ((bar bar)) +(defmethod remove-bar ((bar melody-bar)) (with-slots (slice) bar (assert slice () 'bar-not-in-slice) (with-slots (bars) slice (setf bars (delete bar bars :test #'eq)) (unless bars ;; make sure there is one bar left - (add-bar (make-bar) slice 0))) + (add-bar (make-instance 'melody-bar) slice 0))) + (setf slice nil))) + +(defmethod remove-bar ((bar lyrics-bar)) + (with-slots (slice) bar + (assert slice () 'bar-not-in-slice) + (with-slots (bars) slice + (setf bars (delete bar bars :test #'eq)) + (unless bars + ;; make sure there is one bar left + (add-bar (make-instance 'lyrics-bar) slice 0))) (setf slice nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -592,34 +674,46 @@ (defgeneric tail (layer)) (defclass layer () - ((segment :initform nil :initarg :segment :reader segment) - (staves :initform '() :initarg :staves :accessor staves) + ((name :initform "default layer" :initarg :name :accessor name) + (segment :initform nil :initarg :segment :reader segment) + (staves :initarg :staves :accessor staves) (head :initarg :head :accessor head) (body :initarg :body :accessor body) (tail :initarg :tail :accessor tail))) -(defmethod print-object ((l layer) stream) - (with-slots (head body tail staves) l - (format stream "[_ :staves ~W :head ~W :body ~W :tail ~W ] " - staves head body tail))) - -(defun make-initialized-layer () - (let* ((head (make-initialized-slice)) - (body (make-initialized-slice)) - (tail (make-initialized-slice)) - (result (make-instance 'layer :head head :body body :tail tail))) - (setf (slot-value head 'layer) result - (slot-value body 'layer) result - (slot-value tail 'layer) result) - result)) +;;; melody layer + +(defclass melody-layer (layer) ()) + +(defmethod make-layer (name (initial-staff fiveline-staff)) + (flet ((make-initialized-slice () + (let ((slice (make-empty-slice))) + (add-bar (make-instance 'melody-bar) slice 0) + slice))) + (let* ((head (make-initialized-slice)) + (body (make-initialized-slice)) + (tail (make-initialized-slice)) + (result (make-instance 'melody-layer + :name name :staves (list initial-staff) + :head head :body body :tail tail))) + (setf (slot-value head 'layer) result + (slot-value body 'layer) result + (slot-value tail 'layer) result) + result))) + +(defmethod print-object ((l melody-layer) stream) + (with-slots (head body tail name staves) l + (format stream "[_ :name ~W :staves ~W :head ~W :body ~W :tail ~W ] " + name staves head body tail))) -(defun read-layer-v2 (stream char n) +(defun read-melody-layer-v2 (stream char n) (declare (ignore char n)) (let* ((staves (read stream nil nil t)) (head (read stream nil nil t)) (body (read stream nil nil t)) (tail (read stream nil nil t)) - (layer (make-instance 'layer :staves staves :head head :body body :tail tail))) + (layer (make-instance 'melody-layer + :staves staves :head head :body body :tail tail))) (setf (slot-value head 'layer) layer (slot-value body 'layer) layer (slot-value tail 'layer) layer) @@ -627,20 +721,58 @@ layer)) (set-dispatch-macro-character #\[ #\_ - #'read-layer-v2 + #'read-melody-layer-v2 *gsharp-readtable-v2*) -(defun read-layer-v3 (stream char n) +(defun read-melody-layer-v3 (stream char n) (declare (ignore char n)) (let* ((rest (read-delimited-list #\] stream t)) - (layer (apply #'make-instance 'layer rest))) + (layer (apply #'make-instance 'melody-layer rest))) (setf (slot-value (head layer) 'layer) layer (slot-value (body layer) 'layer) layer (slot-value (tail layer) 'layer) layer) layer)) (set-dispatch-macro-character #\[ #\_ - #'read-layer-v3 + #'read-melody-layer-v3 + *gsharp-readtable-v3*) + +;;; lyrics layer + +(defclass lyrics-layer (layer) ()) + +(defmethod make-layer (name (initial-staff lyrics-staff)) + (flet ((make-initialized-slice () + (let ((slice (make-empty-slice))) + (add-bar (make-instance 'lyrics-bar) slice 0) + slice))) + (let* ((head (make-initialized-slice)) + (body (make-initialized-slice)) + (tail (make-initialized-slice)) + (result (make-instance 'lyrics-layer + :name name :staves (list initial-staff) + :head head :body body :tail tail))) + (setf (slot-value head 'layer) result + (slot-value body 'layer) result + (slot-value tail 'layer) result) + result))) + +(defmethod print-object ((l lyrics-layer) stream) + (with-slots (head body tail name staves) l + (format stream "[M :name ~W :staves ~W :head ~W :body ~W :tail ~W ] " + name staves head body tail))) + +(defun read-lyrics-layer-v3 (stream char n) + (declare (ignore char n)) + (let* ((rest (read-delimited-list #\] stream t)) + (layer (apply #'make-instance 'lyrics-layer rest))) + (setf (slot-value (head layer) 'layer) layer + (slot-value (body layer) 'layer) layer + (slot-value (tail layer) 'layer) layer) + layer)) + +(set-dispatch-macro-character #\[ #\M + #'read-lyrics-layer-v3 *gsharp-readtable-v3*) (defmethod slices ((layer layer)) @@ -657,7 +789,7 @@ (:report (lambda (condition stream) (declare (ignore condition)) - (format stream "That staff already in the layer")))) + (format stream "That staff is already in the layer")))) (define-condition staff-not-in-layer (gsharp-condition) () (:report @@ -674,8 +806,7 @@ (defmethod add-staff-to-layer ((staff staff) (layer layer)) (assert (not (member staff (staves layer) :test #'eq)) () 'staff-already-in-layer) - (setf (staves layer) - (append (staves layer) (list staff)))) + (push staff (staves layer))) (defmethod remove-staff-from-layer ((staff staff) (layer layer)) (assert (not (null (staves layer))) @@ -708,11 +839,8 @@ ;;; and strictly less than the number of layers of the segment. (defgeneric layerno (segment position)) -;;; Add a layer to a segment. The new layer will be inserted before -;;; the element in the position indicated. Values of position must be -;;; greater than or equal to zero and less than or equal to the -;;; current number of segments of the layer. -(defgeneric add-layer (layer segment position)) +;;; Add a layer to a segment. +(defgeneric add-layer (layer segment)) ;;; Delete a layer from the segment to which it belongs (defgeneric remove-layer (layer)) @@ -727,9 +855,9 @@ (defun make-empty-segment () (make-instance 'segment)) -(defun make-initialized-segment () +(defun make-initialized-segment (staff) (let ((segment (make-empty-segment))) - (add-layer (make-initialized-layer) segment 0) + (add-layer (make-layer "Default layer" staff) segment) segment)) (defun read-segment-v2 (stream char n) @@ -769,11 +897,11 @@ (declare (ignore condition)) (format stream "Attempt to add a layer already in a segment")))) -(defmethod add-layer ((layer layer) (seg segment) position) +(defmethod add-layer ((layer layer) (seg segment)) (with-slots (segment) layer (assert (not segment) () 'layer-already-in-a-segment) (with-slots (layers) seg - (setf layers (ninsert-element layer layers position))) + (push layer layers)) (setf segment seg))) (define-condition layer-not-in-segment (gsharp-condition) () @@ -789,7 +917,8 @@ (setf layers (delete layer layers :test #'eq)) ;; make sure there is one layer left (unless layers - (add-layer (make-initialized-layer) segment 0))) + (add-layer (make-layer "Default layer" (car (staves (buffer segment)))) + segment))) (setf segment nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -832,7 +961,8 @@ (defclass buffer () ((segments :initform '() :initarg :segments :accessor segments) - (staves :initform (list (make-fiveline-staff "default")) :initarg :staves :accessor staves) + (staves :initform (list (make-fiveline-staff "default staff")) + :initarg :staves :accessor staves) (min-width :initform *default-min-width* :initarg :min-width :accessor min-width) (spacing-style :initform *default-spacing-style* :initarg :spacing-style :accessor spacing-style) (right-edge :initform *default-right-edge* :initarg :right-edge :accessor right-edge) @@ -849,7 +979,7 @@ (defun make-initialized-buffer () (let ((buffer (make-empty-buffer))) - (add-segment (make-initialized-segment) buffer 0) + (add-segment (make-initialized-segment (car (staves buffer))) buffer 0) buffer)) (defun read-buffer-v2 (stream char n) @@ -912,7 +1042,7 @@ (setf segments (delete segment segments :test #'eq)) ;; make sure there is one segment left (unless segments - (add-segment (make-initialized-segment) buffer 0))) + (add-segment (make-initialized-segment (car (staves buffer))) buffer 0))) (setf buffer nil))) (define-condition staff-already-in-buffer (gsharp-condition) () Index: gsharp/cursor.lisp diff -u gsharp/cursor.lisp:1.1.1.1 gsharp/cursor.lisp:1.2 --- gsharp/cursor.lisp:1.1.1.1 Mon Feb 16 07:46:11 2004 +++ gsharp/cursor.lisp Fri Jul 23 09:51:16 2004 @@ -198,6 +198,9 @@ ;;; ;;; Slice +(defmethod slice ((cursor gsharp-cursor)) + (slice (bar cursor))) + (defgeneric first-slice-p (cursor)) (defgeneric last-slice-p (cursor)) @@ -316,43 +319,17 @@ ;;; ;;; Layer -(defgeneric next-layer (cursor)) +(defmethod layer ((cursor gsharp-cursor)) + (layer (slice cursor))) -(defgeneric previous-layer (cursor)) - -(defmethod next-layer ((cursor gsharp-cursor)) - (let* ((oldbar (bar cursor)) - (oldbarno (number oldbar)) - (oldslice (slice oldbar)) - (oldsliceno (number oldslice)) - (oldlayer (layer oldslice)) - (oldlayerno (number oldlayer)) - (segment (segment oldlayer)) - (nb-layers (nb-layers segment)) - (newlayerno (if (= oldlayerno (1- nb-layers)) - 0 - (1+ oldlayerno))) - (newlayer (layerno segment newlayerno)) - (newslice (sliceno newlayer oldsliceno)) - (newbarno (min (1- (nb-bars newslice)) oldbarno)) - (newbar (barno newslice newbarno))) - (unset-cursor cursor) - (set-cursor cursor newbar 0))) +(defgeneric select-layer (cursor new-layer)) -(defmethod previous-layer ((cursor gsharp-cursor)) +(defmethod select-layer ((cursor gsharp-cursor) (new-layer layer)) (let* ((oldbar (bar cursor)) (oldbarno (number oldbar)) (oldslice (slice oldbar)) (oldsliceno (number oldslice)) - (oldlayer (layer oldslice)) - (oldlayerno (number oldlayer)) - (segment (segment oldlayer)) - (nb-layers (nb-layers segment)) - (newlayerno (if (zerop oldlayerno) - (1- nb-layers) - (1- oldlayerno))) - (newlayer (layerno segment newlayerno)) - (newslice (sliceno newlayer oldsliceno)) + (newslice (sliceno new-layer oldsliceno)) (newbarno (min (1- (nb-bars newslice)) oldbarno)) (newbar (barno newslice newbarno))) (unset-cursor cursor) @@ -368,9 +345,8 @@ ;;; ;;; Segment -(defgeneric insert-layer-before (layer cursor)) - -(defgeneric insert-layer-after (layer cursor)) +(defmethod segment ((cursor gsharp-cursor)) + (segment (layer cursor))) (defgeneric delete-layer (cursor)) @@ -398,14 +374,6 @@ (1- layerno)))) (mapc #'set-cursor cursors)))) -(defmethod insert-layer-before ((layer layer) (cursor gsharp-cursor)) - (let ((cursor-layer (cursor-layer cursor))) - (add-layer layer (segment cursor-layer) (number cursor-layer)))) - -(defmethod insert-layer-after ((layer layer) (cursor gsharp-cursor)) - (let ((cursor-layer (cursor-layer cursor))) - (add-layer layer (segment cursor-layer) (1+ (number cursor-layer))))) - (defmethod delete-layer ((cursor gsharp-cursor)) (remove-layer (cursor-layer cursor))) @@ -415,6 +383,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Buffer + +(defmethod buffer ((cursor gsharp-cursor)) + (buffer (segment cursor))) (defgeneric first-segment-p (cursor)) Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.6 gsharp/drawing.lisp:1.7 --- gsharp/drawing.lisp:1.6 Wed Jul 21 05:42:59 2004 +++ gsharp/drawing.lisp Fri Jul 23 09:51:16 2004 @@ -14,10 +14,14 @@ (format stream "[~a clef on staff step ~a]" (name object) (lineno object))) (define-presentation-method present - (object (type score-pane:staff) stream (view textual-view) &key) - (format stream "[staff ~a]" (name object))) + (object (type score-pane:fiveline-staff) stream (view textual-view) &key) + (format stream "[fiveline staff ~a]" (name object))) -(defmethod draw-staff-and-clef (pane (staff staff) x1 x2) +(define-presentation-method present + (object (type score-pane:lyrics-staff) stream (view textual-view) &key) + (format stream "[lyrics staff ~a]" (name object))) + +(defmethod draw-staff-and-clef (pane (staff fiveline-staff) x1 x2) (when (clef staff) (present (clef staff) `((score-pane:clef) @@ -44,7 +48,13 @@ while (eq (aref (keysig staff) pitch) :sharp) do (score-pane:draw-accidental pane :sharp x (+ line yoffset))))) (present staff - `((score-pane:staff) + `((score-pane:fiveline-staff) + :x1 ,x1 :x2 ,x2) + :stream pane)) + +(defmethod draw-staff-and-clef (pane (staff lyrics-staff) x1 x2) + (present staff + `((score-pane:lyrics-staff) :x1 ,x1 :x2 ,x2) :stream pane)) @@ -115,10 +125,16 @@ (let* ((staves (staves buffer)) (timesig-offset (max (* (score-pane:staff-step 2) (loop for staff in staves - maximize (count :flat (keysig staff)))) + maximize + (if (typep staff 'fiveline-staff) + (count :flat (keysig staff)) + 0))) (* (score-pane:staff-step 2.5) (loop for staff in staves - maximize (count :sharp (keysig staff)))))) + maximize + (if (typep staff 'fiveline-staff) + (count :sharp (keysig staff)) + 0))))) (method (let ((old-method (buffer-cost-method buffer))) (make-measure-cost-method (min-width old-method) (spacing-style old-method) @@ -146,7 +162,7 @@ (decf yy 90)))) buffer))))) -(define-added-mixin velement () element +(define-added-mixin velement () melody-element ((final-stem-direction :accessor final-stem-direction) (final-stem-position :accessor final-stem-position) (final-stem-yoffset :initform 0 :accessor final-stem-yoffset) @@ -156,6 +172,9 @@ (max-yoffset :accessor element-max-yoffset) (xpos :accessor element-xpos))) +(define-added-mixin welement () lyrics-element + ((xpos :accessor element-xpos))) + (defun compute-maxpos-minpos (element) (if (and (typep element 'cluster) (notes element)) (let ((max-note (reduce (lambda (n1 n2) @@ -350,7 +369,7 @@ (defun draw-cursor (pane x) (draw-line* pane x (score-pane:staff-step -4) x (score-pane:staff-step 12) :ink +red+)) -(defmethod draw-bar (pane (bar bar) x width time-alist draw-cursor) +(defmethod draw-bar (pane (bar melody-bar) x width time-alist draw-cursor) (compute-element-x-positions bar x time-alist) (let ((elements (elements bar)) (group '())) @@ -374,6 +393,22 @@ (when (eq (cursor-element *cursor*) element) (funcall draw-cursor (/ (+ xx (element-xpos element)) 2)))))))) +(defmethod draw-bar (pane (bar lyrics-bar) x width time-alist draw-cursor) + (compute-element-x-positions bar x time-alist) + (let ((elements (elements bar))) + (loop for element in elements + do (draw-element pane element (element-xpos element))) + (when (eq (cursor-bar *cursor*) bar) + (if (null (cursor-element *cursor*)) + (funcall draw-cursor (/ (+ (if (null elements) + x + (element-xpos (car (last elements)))) + x width) 2)) + (loop for element in elements + and xx = x then (element-xpos element) do + (when (eq (cursor-element *cursor*) element) + (funcall draw-cursor (/ (+ xx (element-xpos element)) 2)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Cluster @@ -600,3 +635,12 @@ (score-pane:draw-rest pane (notehead-duration element) x (staff-pos element)) (draw-dots pane (dots element) x (1+ (staff-pos element))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Lyrics element + +(defmethod draw-element (pane (element lyrics-element) x &optional (flags t)) + (declare (ignore flags)) + (score-pane:with-vertical-score-position (pane (staff-yoffset (staff element))) + (draw-text* pane (map 'string #'unicode-to-char (text element)) + x 0 :align-x :center))) Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.14 gsharp/gui.lisp:1.15 --- gsharp/gui.lisp:1.14 Wed Jul 21 07:45:43 2004 +++ gsharp/gui.lisp Fri Jul 23 09:51:16 2004 @@ -7,118 +7,47 @@ (bar (barno slice 0))) (make-cursor bar 0))) -(defparameter *global-command-table* (make-hash-table :test #'equal)) -(defparameter *x-command-table* (make-hash-table :test #'equal)) -(defparameter *i-command-table* (make-hash-table :test #'equal)) -(defparameter *ix-command-table* (make-hash-table :test #'equal)) -(defparameter *c-x-command-table* (make-hash-table :test #'equal)) -(defparameter *commands* *global-command-table*) - -(defun add-command (gesture command table) - (setf (gethash (list (car gesture) (apply #'make-modifier-state (cdr gesture))) - table) - command)) - -;;; global command table - -(add-command '(#\L :shift) 'com-lower *global-command-table*) -(add-command '(#\H :shift) 'com-higher *global-command-table*) -(add-command '(#\f :control) 'com-forward-element *global-command-table*) -(add-command '(#\b :control) 'com-backward-element *global-command-table*) -(add-command '(#\d :control) 'com-delete-element *global-command-table*) -(add-command '(#\h :control) 'com-erase-element *global-command-table*) -(add-command '(#\c) 'com-insert-note-c *global-command-table*) -(add-command '(#\d) 'com-insert-note-d *global-command-table*) -(add-command '(#\e) 'com-insert-note-e *global-command-table*) -(add-command '(#\f) 'com-insert-note-f *global-command-table*) -(add-command '(#\g) 'com-insert-note-g *global-command-table*) -(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 '(#\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*) -(add-command '(#\E :shift) 'com-add-note-e *global-command-table*) -(add-command '(#\F :shift) 'com-add-note-f *global-command-table*) -(add-command '(#\G :shift) 'com-add-note-g *global-command-table*) -(add-command '(#\A :shift) 'com-add-note-a *global-command-table*) -(add-command '(#\B :shift) 'com-add-note-b *global-command-table*) -(add-command '(#\h :meta) 'com-rotate-notehead *global-command-table*) -(add-command '(#\s :meta) 'com-rotate-stem-direction *global-command-table*) -(add-command '(#\p) 'com-current-increment *global-command-table*) -(add-command '(#\n) 'com-current-decrement *Global-command-table*) -(add-command '(#\| :shift) 'com-insert-measure-bar *global-command-table*) -(add-command '(#\.) 'com-more-dots *global-command-table*) -(add-command '(#\[) 'com-more-lbeams *global-command-table*) -(add-command '(#\]) 'com-more-rbeams *global-command-table*) -(add-command '(#\#) 'com-sharper *global-command-table*) -(add-command '(#\# :shift) 'com-sharper *global-command-table*) -(add-command '(#\@ :shift) 'com-flatter *global-command-table*) -(add-command '(#\# :meta) 'com-more-sharps *global-command-table*) -(add-command '(#\# :meta :shift) 'com-more-sharps *global-command-table*) -(add-command '(#\@ :meta :shift) 'com-more-flats *global-command-table*) -(add-command '(#\u :meta) 'com-up *global-command-table*) -(add-command '(#\d :meta) 'com-down *global-command-table*) -(add-command '(#\l :meta) 'com-left *global-command-table*) -(add-command '(#\r :meta) 'com-right *global-command-table*) -(add-command '(#\p :meta) 'com-previous-layer *global-command-table*) -(add-command '(#\n :meta) 'com-next-layer *global-command-table*) -(add-command '(#\x) *x-command-table* *global-command-table*) -(add-command '(#\i) *i-command-table* *global-command-table*) -(add-command '(#\x :control) *c-x-command-table* *global-command-table*) - -;;; i command table -(add-command '(#\.) 'com-istate-more-dots *i-command-table*) -(add-command '(#\[) 'com-istate-more-lbeams *i-command-table*) -(add-command '(#\]) 'com-istate-more-rbeams *i-command-table*) -(add-command '(#\h) 'com-istate-rotate-notehead *i-command-table*) -(add-command '(#\s) 'com-istate-rotate-stem-direction *i-command-table*) -(add-command '(#\x) *ix-command-table* *i-command-table*) - -;;; ix command table -(add-command '(#\.) 'com-istate-fewer-dots *ix-command-table*) -(add-command '(#\[) 'com-istate-fewer-lbeams *ix-command-table*) -(add-command '(#\]) 'com-istate-fewer-rbeams *ix-command-table*) - -;;; x-command-table -(add-command '(#\.) 'com-fewer-dots *x-command-table*) -(add-command '(#\[) 'com-fewer-lbeams *x-command-table*) -(add-command '(#\]) 'com-fewer-rbeams *x-command-table*) - -;;; c-x-command-table -(add-command '(#\( :shift) 'com-start-kbd-macro *c-x-command-table*) -(add-command '(#\() 'com-start-kbd-macro *c-x-command-table*) -(add-command '(#\) :shift) 'com-end-kbd-macro *c-x-command-table*) -(add-command '(#\)) 'com-end-kbd-macro *c-x-command-table*) -(add-command '(#\e) 'com-call-last-kbd-macro *c-x-command-table*) - -(defmethod redisplay-gsharp-panes (frame &key force-p) - (loop for pane in (frame-current-panes frame) - do (when (typep pane 'score-pane:score-pane) - (redisplay-frame-pane frame pane :force-p force-p)))) - (defvar *gsharp-frame*) (defparameter *kbd-macro-recording-p* nil) (defparameter *kbd-macro-funs* '()) +(defparameter *accumulated-keys* '()) +(defparameter *modes* (list *global-mode-table*)) +(defparameter *last-character* nil) + (defmethod dispatch-event :around ((pane score-pane:score-pane) (event key-press-event)) (when (keyboard-event-character event) - (let* ((key (list (keyboard-event-character event) - (event-modifier-state event))) - (command (gethash key *commands*))) - (cond ((hash-table-p command) (setf *commands* command)) - ((fboundp command) - (when *kbd-macro-recording-p* (push command *kbd-macro-funs*)) - (handler-case (funcall command) - (gsharp-condition (condition) (format *error-output* "~a~%" condition))) - (setf *commands* *global-command-table*)) - (t (format *error-output* "no command for ~a~%" key) - (setf *commands* *global-command-table*) - (when *kbd-macro-recording-p* (setf *kbd-macro-funs* '() - *kbd-macro-recording-p* nil)))) + (let ((key (list (keyboard-event-character event) + (event-modifier-state event)))) + (setf *accumulated-keys* (append *accumulated-keys* (list key))) + (setf *last-character* (char-to-unicode (car key))) + (let (dico) + (cond ((and (setf dico (find t *modes* + :key (lambda (x) + (multiple-value-bind (value exists-p prefix-p) + (dico-object x *accumulated-keys*) + (declare (ignore value prefix-p)) + exists-p)))) + (fboundp (dico-object dico *accumulated-keys*))) + (let ((command (dico-object dico *accumulated-keys*))) + (when *kbd-macro-recording-p* (push command *kbd-macro-funs*)) + (handler-case (funcall command) + (gsharp-condition (condition) (format *error-output* "~a~%" condition)))) + (setf *accumulated-keys* '())) + ((setf dico (find-if (lambda (x) + (multiple-value-bind (value exists-p prefix-p) + (dico-object x *accumulated-keys*) + (declare (ignore value exists-p)) + prefix-p)) + *modes*)) + nil) + (t (format *error-output* "no command for ~a~%" *accumulated-keys*) + (setf *accumulated-keys* '()) + (when *kbd-macro-recording-p* (setf *kbd-macro-funs* '() + *kbd-macro-recording-p* nil))))) (redisplay-frame-panes *gsharp-frame*)))) - + (define-application-frame gsharp () ((buffer :initarg :buffer :accessor buffer) (cursor :initarg :cursor :accessor cursor) @@ -201,24 +130,33 @@ (defun draw-the-cursor (pane x) (let* ((state (input-state *gsharp-frame*)) - (staff (staff state)) - (yoffset (gsharp-drawing::staff-yoffset staff)) - (clef (clef staff)) - (bottom-line (- (ecase (name clef) (:treble 32) (:bass 24) (:c 35)) - (lineno clef))) - (lnote-offset (score-pane:staff-step (- (last-note state) bottom-line)))) - (draw-line* pane - x (+ (score-pane:staff-step 12) yoffset) - x (+ (score-pane:staff-step -4) yoffset) - :ink +yellow+) - (draw-line* pane - (- x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) - (- x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) - :ink +red+) - (draw-line* pane - (+ x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) - (+ x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) - :ink +red+))) + (staff (car (staves (layer (cursor *gsharp-frame*))))) + (yoffset (gsharp-drawing::staff-yoffset staff))) + (if (typep staff 'fiveline-staff) + (let* ((clef (clef staff)) + (bottom-line (- (ecase (name clef) (:treble 32) (:bass 24) (:c 35)) + (lineno clef))) + (lnote-offset (score-pane:staff-step (- (last-note state) bottom-line)))) + (draw-line* pane + x (+ (score-pane:staff-step 12) yoffset) + x (+ (score-pane:staff-step -4) yoffset) + :ink +yellow+) + (draw-line* pane + (- x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) + (- x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) + :ink +red+) + (draw-line* pane + (+ x 1) (+ (score-pane:staff-step -3.4) yoffset lnote-offset) + (+ x 1) (+ (score-pane:staff-step 3.6) yoffset lnote-offset) + :ink +red+)) + (progn (draw-line* pane + (+ x 1) (+ (score-pane:staff-step 2) yoffset) + (+ x 1) (+ (score-pane:staff-step -2) yoffset) + :ink +red+) + (draw-line* pane + (- x 1) (+ (score-pane:staff-step 2) yoffset) + (- x 1) (+ (score-pane:staff-step -2) yoffset) + :ink +red+))))) (defmethod display-score ((frame gsharp) pane) (let* ((buffer (buffer frame))) @@ -288,6 +226,7 @@ ("Slice" :menu slice-command-table) ("Measure" :menu measure-command-table) ("Modes" :menu modes-command-table) + ("Staves" :menu staves-command-table) ("Play" :menu play-command-table))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -306,7 +245,7 @@ (let* ((buffer (make-initialized-buffer)) (cursor (make-initial-cursor buffer)) (staff (car (staves buffer))) - (input-state (make-input-state staff))) + (input-state (make-input-state))) (setf (buffer *gsharp-frame*) buffer (cursor *gsharp-frame*) cursor (input-state *gsharp-frame*) input-state @@ -344,8 +283,7 @@ :prompt "File Name") (simple-parse-error () (error 'file-not-found)))) (buffer (read-everything filename)) - (staff (car (staves buffer))) - (input-state (make-input-state staff)) + (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) (setf (buffer *gsharp-frame*) buffer (input-state *gsharp-frame*) input-state @@ -398,12 +336,14 @@ (define-gsharp-command (com-insert-segment-before :name t) () (let ((cursor (cursor *gsharp-frame*))) - (insert-segment-before (make-initialized-segment) cursor) + (insert-segment-before (make-initialized-segment (car (staves (buffer *gsharp-frame*)))) + cursor) (backward-segment cursor))) (define-gsharp-command (com-insert-segment-after :name t) () (let ((cursor (cursor *gsharp-frame*))) - (insert-segment-after (make-initialized-segment) cursor) + (insert-segment-after (make-initialized-segment (car (staves (buffer *gsharp-frame*)))) + cursor) (forward-segment cursor))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -413,50 +353,64 @@ (make-command-table 'layer-command-table :errorp nil - :menu '(("Next" :command com-next-layer) - ("Previous" :command com-previous-layer) - ("Delete Current" :command com-delete-layer) - ("Insert After Current" :command com-insert-layer-after) - ("Insert Before Current" :command com-insert-layer-before))) - -(define-gsharp-command (com-next-layer :name t) () - (next-layer (cursor *gsharp-frame*)) - (setf (staff (input-state *gsharp-frame*)) - (car (staves (layer (slice (bar (cursor *gsharp-frame*)))))))) - -(define-gsharp-command (com-previous-layer :name t) () - (previous-layer (cursor *gsharp-frame*)) - (setf (staff (input-state *gsharp-frame*)) - (car (staves (layer (slice (bar (cursor *gsharp-frame*)))))))) + :menu '(("Select" :command com-select-layer) + ("Rename" :command com-rename-layer) + ("New" :command com-add-layer) + ("Delete" :command com-delete-layer))) +(define-condition layer-name-not-unique (gsharp-condition) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Layer name already exists")))) -(define-gsharp-command (com-delete-layer :name t) () - (delete-layer (cursor *gsharp-frame*))) +(defun acquire-unique-layer-name (prompt) + (let ((name (accept 'string :prompt prompt))) + (assert (not (member name (layers (segment (cursor *gsharp-frame*))) + :test #'string= :key #'name)) + () `layer-name-not-unique) + name)) -(define-gsharp-command (com-insert-layer-before :name t) ((staff-name 'string :prompt "Staff")) - (let ((cursor (cursor *gsharp-frame*)) - (staff (find-staff staff-name (buffer *gsharp-frame*)))) - (if (not staff) - (message "No such staff in buffer~%") - (progn (insert-layer-before (make-initialized-layer) cursor) - (previous-layer cursor) - (let ((layer (layer (slice (bar (cursor *gsharp-frame*)))))) - (add-staff-to-layer staff layer) - (setf (staff (input-state *gsharp-frame*)) - staff)))))) +(define-condition no-such-layer (gsharp-condition) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "No such layer")))) -(define-gsharp-command (com-insert-layer-after :name t) () - (let ((cursor (cursor *gsharp-frame*)) - (staff (accept 'score-pane:staff :prompt "Staff"))) -;;; (staff (find-staff staff-name (buffer *gsharp-frame*)))) - (if (not staff) - (message "No such staff in buffer~%") - (progn (insert-layer-after (make-initialized-layer) cursor) - (next-layer cursor) - (let ((layer (layer (slice (bar (cursor *gsharp-frame*)))))) - (add-staff-to-layer staff layer) - (setf (staff (input-state *gsharp-frame*)) - staff)))))) +(define-presentation-method accept + ((type layer) stream (view textual-view) &key) + (multiple-value-bind (layer success string) + (handler-case (complete-input stream + (lambda (so-far mode) + (complete-from-possibilities + so-far + (layers (segment (cursor *gsharp-frame*))) + '() + :action mode + :predicate (lambda (obj) (declare (ignore obj)) t) + :name-key #'name + :value-key #'identity))) + (simple-parse-error () (error 'no-such-layer))) + (declare (ignore string)) + (if success layer (error 'no-such-layer)))) + +(define-gsharp-command (com-select-layer :name t) () + (let ((selected-layer (accept 'layer :prompt "Select layer"))) + (select-layer (cursor *gsharp-frame*) selected-layer))) + +(define-gsharp-command (com-rename-layer :name t) () + (setf (name (accept 'layer :prompt "Rename layer")) + (acquire-unique-layer-name "New name of layer"))) + +(define-gsharp-command (com-add-layer :name t) () + (let* ((name (acquire-unique-layer-name "Name of new layer")) + (staff (accept 'score-pane:staff :prompt "Initial staff of new layer")) + (new-layer (make-layer name staff))) + (add-layer new-layer (segment (cursor *gsharp-frame*))) + (select-layer (cursor *gsharp-frame*) new-layer))) + +(define-gsharp-command (com-delete-layer :name t) () + (delete-layer (cursor *gsharp-frame*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -514,6 +468,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; staves menu + +(make-command-table + 'staves-command-table + :errorp nil + :menu '(("Rotate" :command com-rotate-staves))) + +(define-gsharp-command (com-rotate-staves :name t) () + (let ((layer (layer (cursor *gsharp-frame*)))) + (setf (staves layer) + (append (cdr (staves layer)) (list (car (staves layer))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; play menu (make-command-table @@ -588,7 +556,7 @@ (error "write compatibility layer for RUN-PROGRAM"))) (define-gsharp-command (com-play-layer :name t) () - (let* ((slice (body (layer (slice (bar (cursor *gsharp-frame*)))))) + (let* ((slice (body (layer (cursor *gsharp-frame*)))) (durations (measure-durations (list slice))) (tracks (list (track-from-slice slice 0 durations))) (midifile (make-instance 'midifile @@ -609,7 +577,7 @@ (setq climi::*all-ports* nil) (let* ((buffer (make-initialized-buffer)) (staff (car (staves buffer))) - (input-state (make-input-state staff)) + (input-state (make-input-state)) (cursor (make-initial-cursor buffer))) (setf *gsharp-frame* (make-application-frame 'gsharp :buffer buffer @@ -639,11 +607,11 @@ (defun insert-note (pitch cluster) (let* ((state (input-state *gsharp-frame*)) + (staff (car (staves (layer (slice (bar cluster)))))) (note (make-note pitch - (staff state) + staff (notehead state) - (aref (keysig (staff state)) (mod pitch 7)) -;;; (accidentals state) + (aref (keysig staff) (mod pitch 7)) (dots state)))) (setf *current-cluster* cluster *current-note* note) @@ -690,7 +658,7 @@ (if (eq (notehead state) :filled) (lbeams state) 0) (dots state) (notehead state) - (staff (input-state *gsharp-frame*))))) + (car (staves (layer (cursor *gsharp-frame*))))))) (insert-element rest cursor) (forward-element cursor) rest)) @@ -972,10 +940,11 @@ (:up :down) (:down :auto)))) -(define-gsharp-command (com-set-clef :name t) ((name '(member :treble :bass :c)) - (line '(or integer null) :prompt "Line")) - (setf (clef (staff (input-state *gsharp-frame*))) - (make-clef name line))) +(define-gsharp-command (com-set-clef :name t) () + (let ((staff (accept 'score-pane:fiveline-staff :prompt "Set clef of staff")) + (type (accept 'clef-type :prompt "Type of clef")) + (line (accept 'integer :prompt "Line of clef"))) + (setf (clef staff) (make-clef type line)))) (define-gsharp-command com-higher () (incf (last-note (input-state *gsharp-frame*)) 7)) @@ -989,7 +958,7 @@ (loop until (end-of-bar-p cursor) do (push (cursor-element cursor) elements) do (delete-element cursor)) - (insert-bar-after (make-bar) cursor) + (insert-bar-after (make-instance (class-of (bar cursor))) cursor) (forward-bar cursor) (loop for element in elements do (insert-element element cursor)))) @@ -1022,7 +991,7 @@ (if success staff (error 'no-such-staff)))) (define-presentation-method accept - ((type fiveline-staff) stream (view textual-view) &key) + ((type score-pane:fiveline-staff) stream (view textual-view) &key) (multiple-value-bind (staff success string) (handler-case (complete-input stream (lambda (so-far mode) @@ -1056,7 +1025,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - '(:fiveline) + '(:fiveline :lyrics) '() :action mode :predicate (lambda (obj) (declare (ignore obj)) t) @@ -1093,26 +1062,27 @@ (declare (ignore condition)) (format stream "Staff name already exists")))) -(defun acquire-unique-staff-name () - (let ((name (accept 'string :prompt "Staff name"))) +(defun acquire-unique-staff-name (prompt) + (let ((name (accept 'string :prompt prompt))) (assert (not (member name (staves (buffer *gsharp-frame*)) :test #'string= :key #'name)) () `staff-name-not-unique) name)) (defun acquire-new-staff () - (let ((name (acquire-unique-staff-name))) + (let ((name (acquire-unique-staff-name "Name of new staff"))) (ecase (accept 'staff-type :prompt "Type") - (:fiveline (let ((clef (accept 'clef-type :prompt "Clef")) - (line (accept 'integer :prompt "Line"))) - (make-fiveline-staff name (make-clef clef line))))))) + (:fiveline (let ((clef (accept 'clef-type :prompt "Clef type of new staff")) + (line (accept 'integer :prompt "Line of clef"))) + (make-fiveline-staff name (make-clef clef line)))) + (:lyrics (make-lyrics-staff name))))) -(define-gsharp-command (com-add-staff-before :name t) () - (add-staff-before-staff (accept 'score-pane:staff :prompt "Before staff") +(define-gsharp-command (com-insert-staff-before :name t) () + (add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff before staff") (acquire-new-staff) (buffer *gsharp-frame*))) -(define-gsharp-command (com-add-staff-after :name t) () - (add-staff-after-staff (accept 'score-pane:staff :prompt "After staff") +(define-gsharp-command (com-insert-staff-after :name t) () + (add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff after staff") (acquire-new-staff) (buffer *gsharp-frame*))) @@ -1121,23 +1091,24 @@ (buffer *gsharp-frame*))) (define-gsharp-command (com-rename-staff :name t) () - (let* ((staff (accept 'score-pane:staff :prompt "Staff")) - (name (acquire-unique-staff-name)) + (let* ((staff (accept 'score-pane:staff :prompt "Rename staff")) + (name (acquire-unique-staff-name "New name of staff")) (buffer (buffer *gsharp-frame*))) (rename-staff name staff buffer))) -(define-gsharp-command (com-add-layer-staff :name t) () - (let ((staff (accept 'score-pane:staff :prompt "Staff")) - (layer (layer (slice (bar (cursor *gsharp-frame*)))))) +(define-gsharp-command (com-add-staff-to-layer :name t) () + (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer")) + (layer (layer (cursor *gsharp-frame*)))) (add-staff-to-layer staff layer))) -(define-gsharp-command (com-delete-layer-staff :name t) ((name 'string)) - (let ((staff (find-staff name (buffer *gsharp-frame*))) - (layer (layer (slice (bar (cursor *gsharp-frame*)))))) +;;; FIXME restrict to staves that are actually in the layer. +(define-gsharp-command (com-delete-staff-from-layer :name t) () + (let ((staff (accept 'score-pane:staff :prompt "Add staff to layer")) + (layer (layer (cursor *gsharp-frame*)))) (remove-staff-from-layer staff layer))) (define-gsharp-command com-more-sharps () - (let ((keysig (keysig (staff (input-state *gsharp-frame*))))) + (let ((keysig (keysig (car (staves (layer (cursor *gsharp-frame*))))))) (cond ((eq (aref keysig 3) :flat) (setf (aref keysig 3) :natural)) ((eq (aref keysig 0) :flat) (setf (aref keysig 0) :natural)) ((eq (aref keysig 4) :flat) (setf (aref keysig 4) :natural)) @@ -1154,7 +1125,7 @@ ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :sharp))))) (define-gsharp-command com-more-flats () - (let ((keysig (keysig (staff (input-state *gsharp-frame*))))) + (let ((keysig (keysig (car (staves (layer (cursor *gsharp-frame*))))))) (cond ((eq (aref keysig 6) :sharp) (setf (aref keysig 6) :natural)) ((eq (aref keysig 2) :sharp) (setf (aref keysig 2) :natural)) ((eq (aref keysig 5) :sharp) (setf (aref keysig 5) :natural)) Index: gsharp/input-state.lisp diff -u gsharp/input-state.lisp:1.1.1.1 gsharp/input-state.lisp:1.2 --- gsharp/input-state.lisp:1.1.1.1 Mon Feb 16 07:46:17 2004 +++ gsharp/input-state.lisp Fri Jul 23 09:51:16 2004 @@ -7,8 +7,7 @@ (notehead :initform :filled :accessor notehead) (stem-direction :initform :auto :accessor stem-direction) (last-note :initform 34 :accessor last-note) ; a B in the fourth octave - (accidentals :initform :natural :accessor accidentals) - (staff :initarg :staff :accessor staff))) + (accidentals :initform :natural :accessor accidentals))) -(defun make-input-state (staff) - (make-instance 'input-state :staff staff)) +(defun make-input-state () + (make-instance 'input-state)) Index: gsharp/measure.lisp diff -u gsharp/measure.lisp:1.2 gsharp/measure.lisp:1.3 --- gsharp/measure.lisp:1.2 Mon Feb 16 08:08:00 2004 +++ gsharp/measure.lisp Fri Jul 23 09:51:16 2004 @@ -154,8 +154,7 @@ (when (buffer segment) (mark-modified (buffer segment)))) -(defmethod add-layer :after ((layer layer) (segment rsegment) position) - (declare (ignore position)) +(defmethod add-layer :after ((layer layer) (segment rsegment)) (mark-modified segment)) (defmethod remove-layer :before ((layer rlayer)) Index: gsharp/numbering.lisp diff -u gsharp/numbering.lisp:1.1.1.1 gsharp/numbering.lisp:1.2 --- gsharp/numbering.lisp:1.1.1.1 Mon Feb 16 07:46:18 2004 +++ gsharp/numbering.lisp Fri Jul 23 09:51:16 2004 @@ -82,8 +82,7 @@ (defnclass nsegment segment ()) -(defmethod add-layer :after ((layer nlayer) (segment segment) position) - (declare (ignore position)) +(defmethod add-layer :after ((layer nlayer) (segment segment)) (number-elements (layers segment))) (defmethod remove-layer :around ((layer nlayer)) Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.6 gsharp/packages.lisp:1.7 --- gsharp/packages.lisp:1.6 Wed Jul 21 05:43:00 2004 +++ gsharp/packages.lisp Fri Jul 23 09:51:16 2004 @@ -1,7 +1,13 @@ +(defpackage :sequence-dico + (:use :clim-lisp) + (:export #:sequence-dico #:standard-sequence-dico + #:make-sequence-dico #:dico-object)) + (defpackage :gsharp-utilities (:shadow built-in-class) (:use :clim-lisp :clim-mop) - (:export #:ninsert-element #:define-added-mixin)) + (:export #:ninsert-element #:define-added-mixin + #:unicode-to-char #:char-to-unicode)) (defpackage :gf (:use :common-lisp) @@ -36,18 +42,24 @@ (:use :common-lisp :gsharp-utilities) (:shadow #:rest) (:export #:clef #:make-clef #:name #:lineno - #:staff #:fiveline-staff #:make-fiveline-staff #:gsharp-condition - #:pitch #:accidentals #:dots #:cluster #:note + #:staff #:fiveline-staff #:make-fiveline-staff + #:lyrics-staff #:make-lyrics-staff + #:gsharp-condition + #:pitch #:accidentals #:dots #:note #:make-note #:note-less #:note-equal #:bar - #:notehead #:rbeams #:lbeams #:dots #:element #:notes + #:notehead #:rbeams #:lbeams #:dots #:element + #:melody-element #:notes #:add-note #:find-note #:remove-note #:cluster #:make-cluster - #:rest #:make-rest #:slice #:elements + #:rest #:make-rest #:lyrics-element + #:slice #:elements #:nb-elements #:elementno #:add-element - #:remove-element #:bar #:make-bar #:layer + #:remove-element #:bar #:make-bar + #:melody-bar #:lyrics-bar + #:layer #:bars #:nb-bars #:barno #:add-bar #:remove-bar - #:slice #:make-empty-slice #:make-initialized-slice + #:slice #:segment #:slices #:sliceno - #:head #:body #:tail #:make-initialized-layer #:buffer + #:head #:body #:tail #:make-layer #:buffer #:make-empty-buffer #:make-initialized-buffer #:layers #:nb-layers #:layerno #:add-layer #:remove-layer #:segment @@ -62,7 +74,7 @@ #:stem-direction #:stem-length #:notehead-duration #:element-duration #:clef #:keysig #:staff-pos #:xoffset #:read-everything #:save-buffer-to-stream #:line-width #:min-width #:spacing-style #:right-edge #:left-offset - #:left-margin + #:left-margin #:text )) (defpackage :gsharp-numbering @@ -122,7 +134,8 @@ (defpackage :score-pane (:use :clim :clim-extensions :clim-lisp :sdl) (:shadow #:rest) - (:export #:draw-staff #:draw-stem #:draw-right-stem #:draw-left-stem + (:export #:draw-fiveline-staff #:draw-lyrics-staff + #:draw-stem #:draw-right-stem #:draw-left-stem #:draw-ledger-line #:draw-bar-line #:draw-beam #:staff-step #:draw-notehead #:draw-accidental #:draw-clef #:draw-rest #:draw-dot #:draw-flags-up #:draw-flags-down @@ -130,7 +143,7 @@ #:with-staff-size #:with-notehead-right-offsets #:with-suspended-note-offset #:with-notehead-left-offsets #:with-light-glyphs #:score-pane - #:clef #:staff #:notehead)) + #:clef #:staff #:fiveline-staff #:lyrics-staff #:notehead)) (defpackage :gsharp-beaming (:use :common-lisp) @@ -150,8 +163,7 @@ #:forward-slice #:backward-slice #:head-slice #:body-slice #:tail-slice #:in-last-slice #:in-first-slice - #:next-layer #:previous-layer - #:insert-layer-before #:insert-layer-after #:delete-layer + #:select-layer #:delete-layer #:forward-segment #:backward-segment #:insert-segment-before #:insert-segment-after #:delete-segment @@ -184,9 +196,9 @@ #:unknown-event #:status #:data-byte)) (defpackage :gsharp - (:use :clim :clim-lisp + (:use :clim :clim-lisp :gsharp-utilities :gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering - :gsharp-measure :sdl :midi) + :gsharp-measure :sdl :midi :sequence-dico) (:shadowing-import-from :gsharp-numbering #:number) (:shadowing-import-from :gsharp-buffer #:rest)) Index: gsharp/score-pane.lisp diff -u gsharp/score-pane.lisp:1.5 gsharp/score-pane.lisp:1.6 --- gsharp/score-pane.lisp:1.5 Wed Jul 21 05:43:00 2004 +++ gsharp/score-pane.lisp Fri Jul 23 09:51:16 2004 @@ -417,16 +417,31 @@ (define-presentation-type staff () :options (x1 x2)) -(defun draw-staff (pane x1 x2) +(define-presentation-type fiveline-staff () :inherit-from 'staff :options (x1 x2)) + +(defun draw-fiveline-staff (pane x1 x2) (multiple-value-bind (left right) (bar-line-offsets *font*) (loop for staff-step from 0 by 2 repeat 5 do (draw-staff-line pane (+ x1 left) staff-step (+ x2 right))))) (define-presentation-method present - (object (type staff) stream (view score-view) &key) - (with-output-as-presentation (stream object 'staff) - (draw-staff stream x1 x2))) + (object (type fiveline-staff) stream (view score-view) &key) + (with-output-as-presentation (stream object 'fiveline-staff) + (draw-fiveline-staff stream x1 x2))) + +(define-presentation-type lyrics-staff () :inherit-from 'staff :options (x1 x2)) + +(defun draw-lyrics-staff (pane x1 x2) + (declare (ignore x2)) + (multiple-value-bind (left right) (bar-line-offsets *font*) + (declare (ignore right)) + (draw-text* pane "--" (+ x1 left) 0))) + +(define-presentation-method present + (object (type lyrics-staff) stream (view score-view) &key) + (with-output-as-presentation (stream object 'lyrics-staff) + (draw-lyrics-staff stream x1 x2))) ;;;;;;;;;;;;;;;;;; stem Index: gsharp/system.lisp diff -u gsharp/system.lisp:1.3 gsharp/system.lisp:1.4 --- gsharp/system.lisp:1.3 Mon Feb 16 10:50:59 2004 +++ gsharp/system.lisp Fri Jul 23 09:51:16 2004 @@ -22,6 +22,7 @@ (gsharp-defsystem (:gsharp) "packages" + "sequence-dico" "utilities" "gf" "sdl" @@ -38,4 +39,5 @@ "cursor" "input-state" "midi" + "modes" "gui") Index: gsharp/utilities.lisp diff -u gsharp/utilities.lisp:1.1.1.1 gsharp/utilities.lisp:1.2 --- gsharp/utilities.lisp:1.1.1.1 Mon Feb 16 07:46:21 2004 +++ gsharp/utilities.lisp Fri Jul 23 09:51:16 2004 @@ -71,3 +71,34 @@ (when (symbolp c1) (setf c1 (find-class c1))) (when (symbolp c2) (setf c2 (find-class c2))) (eq c1 c2)) + +;;; Unicode utilities + +(defparameter *char-to-unicode-table* (make-hash-table)) +(defparameter *unicode-to-char-table* (make-hash-table)) + +(defun char-to-unicode (char) + (or (gethash char *char-to-unicode-table*) 0)) + +(defun unicode-to-char (unicode) + (or (gethash unicode *unicode-to-char-table*) #\_)) + +(defun set-char-unicode-correspondance (char unicode) + (setf (gethash char *char-to-unicode-table*) unicode + (gethash unicode *unicode-to-char-table*) char)) + +(loop for char in '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) + for code from 65 + do (set-char-unicode-correspondance char code)) + +(loop for char in '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) + for code from 97 + do (set-char-unicode-correspondance char code)) + +(loop for char in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + for code from 48 + do (set-char-unicode-correspondance char code)) + +