From rstrandh at common-lisp.net Mon Feb 6 04:17:19 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Sun, 5 Feb 2006 22:17:19 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060206041719.C54052A036@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv4809 Modified Files: drawing.lisp Log Message: Fixed a bug that made Gsharp crash in left-bulge and right-bulge for empty clusters. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/01/25 00:50:56 1.57 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/06 04:17:19 1.58 @@ -135,7 +135,8 @@ (+ (max (- (loop for note in (notes element) when (final-accidental note) minimize (final-relative-accidental-xoffset note))) - (if (and (eq (final-stem-direction element) :down) + (if (and (non-empty-cluster-p element) + (eq (final-stem-direction element) :down) (element-has-suspended-notes element)) (score-pane:staff-step 3) (score-pane:staff-step 0))) @@ -149,7 +150,8 @@ (/ (text-size pane (map 'string 'code-char (text element))) 2))) (defmethod right-bulge ((element cluster) pane) - (if (and (eq (final-stem-direction element) :up) + (if (and (non-empty-cluster-p element) + (eq (final-stem-direction element) :up) (element-has-suspended-notes element)) (score-pane:staff-step 5) (score-pane:staff-step 2))) From rstrandh at common-lisp.net Mon Feb 6 04:20:23 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Sun, 5 Feb 2006 22:20:23 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060206042023.8DAB42A036@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv4851 Modified Files: buffer.lisp Log Message: Changed the external format for buffers. Instead of dispatching on a single letter we now put the full name of the class to instantiate in the external format. This modification will make it easier to extend the buffer with new kinds of objects, both for the Gsharp developers and (ultimately) for the advanced users. For that to happen, the buffer protocols will have to be documented, of course. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/01/21 23:39:16 1.29 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/06 04:20:23 1.30 @@ -1,29 +1,39 @@ (in-package :gsharp-buffer) (defparameter *gsharp-readtable-v3* (copy-readtable)) +(defparameter *gsharp-readtable-v4* (copy-readtable)) (make-dispatch-macro-character #\[ nil *gsharp-readtable-v3*) -(defun skip-until-close-bracket (stream) - (loop until (eql (read-char stream) #\]))) +(defun read-gsharp-object-v4 (stream char) + (declare (ignore char)) + (apply #'make-instance (read-delimited-list #\] stream t))) + +(set-macro-character #\[ #'read-gsharp-object-v4 nil *gsharp-readtable-v4*) (defclass gsharp-object () ()) -(defmethod print-object ((obj gsharp-object) stream) - nil) +(defgeneric print-gsharp-object (obj stream)) + +(defmethod print-gsharp-object ((obj gsharp-object) stream) + (format stream "~s ~2i" (class-name (class-of obj)))) -(defmethod print-object :around ((obj gsharp-object) stream) - (format stream "[~a " (slot-value obj 'print-character)) - (call-next-method) - (format stream "] ")) +;;; (defmethod print-object :around ((obj gsharp-object) stream) +;;; (format stream "[~a " (slot-value obj 'print-character)) +;;; (call-next-method) +;;; (format stream "] ")) + +(defmethod print-object ((obj gsharp-object) stream) + (pprint-logical-block (stream nil :prefix "[" :suffix "]") + (print-gsharp-object obj stream))) (defgeneric name (obj)) (defclass name-mixin () ((name :initarg :name :accessor name))) -(defmethod print-object :after ((obj name-mixin) stream) - (format stream ":name ~W " (name obj))) +(defmethod print-gsharp-object :after ((obj name-mixin) stream) + (format stream "~_:name ~W " (name obj))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -50,8 +60,8 @@ (:percussion 3)))) (make-instance 'clef :name name :lineno lineno)) -(defmethod print-object :after ((c clef) stream) - (format stream ":lineno ~W " (lineno c))) +(defmethod print-gsharp-object :after ((c clef) stream) + (format stream "~_:lineno ~W " (lineno c))) (defun read-clef-v3 (stream char n) (declare (ignore char n)) @@ -83,8 +93,8 @@ (declare (ignore name clef keysig)) (apply #'make-instance 'fiveline-staff args)) -(defmethod print-object :after ((s fiveline-staff) stream) - (format stream ":clef ~W :keysig ~W " (clef s) (keysig s))) +(defmethod print-gsharp-object :after ((s fiveline-staff) stream) + (format stream "~_:clef ~W ~_:keysig ~W " (clef s) (keysig s))) (defun read-fiveline-staff-v3 (stream char n) (declare (ignore char n)) @@ -179,10 +189,10 @@ (ignore head accidentals dots)) (apply #'make-instance 'note :pitch pitch :staff staff args)) -(defmethod print-object :after ((n note) stream) +(defmethod print-gsharp-object :after ((n note) stream) (with-slots (pitch staff head accidentals dots) n (format stream - ":pitch ~W :staff ~W :head ~W :accidentals ~W :dots ~W " + "~_:pitch ~W ~_:staff ~W ~_:head ~W ~_:accidentals ~W ~_:dots ~W " pitch staff head accidentals dots))) (defun read-note-v3 (stream char n) @@ -237,10 +247,10 @@ (dots :initform 0 :initarg :dots :accessor dots) (xoffset :initform 0 :initarg :xoffset :accessor xoffset))) -(defmethod print-object :after ((e element) stream) +(defmethod print-gsharp-object :after ((e element) stream) (with-slots (notehead rbeams lbeams dots xoffset) e (format stream - ":notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W " + "~_:notehead ~W ~_:rbeams ~W ~_:lbeams ~W ~_:dots ~W ~_:xoffset ~W " notehead rbeams lbeams dots xoffset))) (defmethod undotted-duration ((element element)) @@ -307,9 +317,9 @@ (ignore notehead lbeams rbeams dots xoffset notes stem-direction)) (apply #'make-instance 'cluster args)) -(defmethod print-object :after ((c cluster) stream) +(defmethod print-gsharp-object :after ((c cluster) stream) (with-slots (stem-direction notes) c - (format stream ":stem-direction ~W :notes ~W " stem-direction notes))) + (format stream "~_:stem-direction ~W ~_:notes ~W " stem-direction notes))) (defun read-cluster-v3 (stream char n) (declare (ignore char n)) @@ -393,9 +403,9 @@ (apply #'make-instance 'rest :staff staff args)) -(defmethod print-object :after ((s rest) stream) +(defmethod print-gsharp-object :after ((s rest) stream) (with-slots (staff staff-pos) s - (format stream ":staff ~W :staff-pos ~W " staff staff-pos))) + (format stream "~_:staff ~W ~_:staff-pos ~W " staff staff-pos))) (defun read-rest-v3 (stream char n) (declare (ignore char n)) @@ -437,9 +447,9 @@ (apply #'make-instance 'lyrics-element :staff staff args)) -(defmethod print-object :after ((elem lyrics-element) stream) +(defmethod print-gsharp-object :after ((elem lyrics-element) stream) (with-slots (staff text) elem - (format stream ":staff ~W :text ~W " staff text))) + (format stream "~_:staff ~W ~_:text ~W " staff text))) (defun read-lyrics-element-v3 (stream char n) (declare (ignore char n)) @@ -492,8 +502,8 @@ (loop for element in (elements b) do (setf (bar element) b))) -(defmethod print-object :after ((b bar) stream) - (format stream ":elements ~W " (elements b))) +(defmethod print-gsharp-object :after ((b bar) stream) + (format stream "~_:elements ~W " (elements b))) ;;; The duration of a bar is simply the sum of durations ;;; of its elements. We might want to improve on the @@ -615,8 +625,8 @@ (ignore bars)) (apply #'make-instance 'slice args)) -(defmethod print-object :after ((s slice) stream) - (format stream ":bars ~W " (bars s))) +(defmethod print-gsharp-object :after ((s slice) stream) + (format stream "~_:bars ~W " (bars s))) (defun read-slice-v3 (stream char n) (declare (ignore char n)) @@ -721,9 +731,9 @@ (layer (body l)) l (layer (tail l)) l)) -(defmethod print-object :after ((l layer) stream) +(defmethod print-gsharp-object :after ((l layer) stream) (with-slots (head body tail staves) l - (format stream ":staves ~W :head ~W :body ~W :tail ~W " + (format stream "~_:staves ~W ~_:head ~W ~_:body ~W ~_:tail ~W " staves head body tail))) (defgeneric make-layer-for-staff (staff &rest args &key staves head body tail &allow-other-keys)) @@ -852,8 +862,8 @@ (loop for layer in layers do (setf (segment layer) s)))) -(defmethod print-object :after ((s segment) stream) - (format stream ":layers ~W " (layers s))) +(defmethod print-gsharp-object :after ((s segment) stream) + (format stream "~_:layers ~W " (layers s))) (defun read-segment-v3 (stream char n) (declare (ignore char n)) @@ -970,10 +980,11 @@ (loop for segment in segments do (setf (buffer segment) b)))) -(defmethod print-object :after ((b buffer) stream) +(defmethod print-gsharp-object :after ((b buffer) stream) (with-slots (staves segments min-width spacing-style right-edge left-offset left-margin) b - (format stream ":staves ~W :segments ~W :min-width ~W :spacing-style ~W :right-edge ~W :left-offset ~W :left-margin ~W " - staves segments min-width spacing-style right-edge left-offset left-margin))) + (format stream + "~_:min-width ~W ~_:spacing-style ~W ~_:right-edge ~W ~_:left-offset ~W ~_:left-margin ~W ~_:staves ~W ~_:segments ~W " + min-width spacing-style right-edge left-offset left-margin staves segments ))) (defun read-buffer-v3 (stream char n) (declare (ignore char n)) @@ -1095,7 +1106,8 @@ (format stream "Unknown file version")))) (defparameter *readtables* - `(("G#V3" . ,*gsharp-readtable-v3*))) + `(("G#V3" . ,*gsharp-readtable-v3*) + ("G#V4" . ,*gsharp-readtable-v4*))) (defun read-everything (filename) (assert (probe-file filename) () 'file-does-not-exist) @@ -1108,8 +1120,10 @@ (read stream))))) (defun save-buffer-to-stream (buffer stream) - (let ((*print-circle* t)) - (format stream "G#V3~%") - (print buffer stream) + (let ((*print-circle* t) + (*package* (find-package :keyword))) + ;; (format stream "G#V3~%") + (format stream "G#V4~%") + (pprint buffer stream) (terpri stream) (finish-output stream))) From rstrandh at common-lisp.net Tue Feb 7 03:02:31 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 6 Feb 2006 21:02:31 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060207030231.3DBD52A034@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv24231 Modified Files: drawing.lisp Log Message: Fixed a bug so that the explicit x-offset of an element is again taken into account. Removed a function that is no longer used. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/06 04:17:19 1.58 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/07 03:02:31 1.59 @@ -297,7 +297,8 @@ then (+ xx (max (smallest-gap timeline) (* force (elasticity timeline)))) do (loop for element in (elements timeline) - do (setf (final-absolute-element-xoffset element) xx))) + do (setf (final-absolute-element-xoffset element) + (+ xx (score-pane:staff-step (xoffset element)))))) (loop for bar in (measure-bars measure) do (compute-bar-coordinates bar x y (size-at-force (elasticity-function measure) force)))) @@ -457,16 +458,6 @@ (+ top-note-pos length) (- bot-note-pos length))))) -(defun compute-element-x-positions (bar x time-alist) - (let ((start-time 0)) - (mapc (lambda (element) - (setf (final-absolute-element-xoffset element) - (round (+ x - (score-pane:staff-step (xoffset element)) - (cdr (assoc start-time time-alist))))) - (incf start-time (duration element))) - (elements bar)))) - ;;; the dominating note among a bunch of notes is the ;;; one that is closest to the beam, i.e. the one ;;; the one that is closest to the end of the stem that From rstrandh at common-lisp.net Tue Feb 7 04:52:07 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 6 Feb 2006 22:52:07 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060207045207.46F5446013@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv4828 Modified Files: drawing.lisp Log Message: Fixed an off-by-one-pixel problem between a beam and a stem. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/07 03:02:31 1.59 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/07 04:52:06 1.60 @@ -298,7 +298,7 @@ (* force (elasticity timeline)))) do (loop for element in (elements timeline) do (setf (final-absolute-element-xoffset element) - (+ xx (score-pane:staff-step (xoffset element)))))) + (round (+ xx (score-pane:staff-step (xoffset element))))))) (loop for bar in (measure-bars measure) do (compute-bar-coordinates bar x y (size-at-force (elasticity-function measure) force)))) From rstrandh at common-lisp.net Wed Feb 8 18:36:29 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Wed, 8 Feb 2006 12:36:29 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060208183629.2935A77016@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv21781 Modified Files: buffer.lisp Log Message: Embryonic key signature protocol. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/06 04:20:23 1.30 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/08 18:36:28 1.31 @@ -276,6 +276,65 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Key signature + +(defgeneric alterations (key-signature) + (:documentation "return the alterations in the form of a +7-element array where each element is either :natural, +:sharp, or :flat according to how each staff position +should be altered")) + +(defgeneric more-sharps (key-signature &optional n) + (:documentation "make the key signature N alterations +sharper by removing some flats and/or adding some sharps")) + +(defgeneric more-flats (key-signature &optional n) + (:documentation "make the key signature N alterations +flatter by removing some sharps and/or adding some flats")) + +(defclass key-signature (melody-element) + ((%staff :initarg :staff :reader staff) + (%alterations :initform (make-array 7 :initial-element :natural) + :initarg :alterations :reader alterations))) + +(defmethod more-sharps ((sig key-signature) &optional (n 1)) + (let ((alt (alterations sig))) + (loop repeat n + do (cond ((eq (aref alt 3) :flat) (setf (aref alt 3) :natural)) + ((eq (aref alt 0) :flat) (setf (aref alt 0) :natural)) + ((eq (aref alt 4) :flat) (setf (aref alt 4) :natural)) + ((eq (aref alt 1) :flat) (setf (aref alt 1) :natural)) + ((eq (aref alt 5) :flat) (setf (aref alt 5) :natural)) + ((eq (aref alt 2) :flat) (setf (aref alt 2) :natural)) + ((eq (aref alt 6) :flat) (setf (aref alt 6) :natural)) + ((eq (aref alt 3) :natural) (setf (aref alt 3) :sharp)) + ((eq (aref alt 0) :natural) (setf (aref alt 0) :sharp)) + ((eq (aref alt 4) :natural) (setf (aref alt 4) :sharp)) + ((eq (aref alt 1) :natural) (setf (aref alt 1) :sharp)) + ((eq (aref alt 5) :natural) (setf (aref alt 5) :sharp)) + ((eq (aref alt 2) :natural) (setf (aref alt 2) :sharp)) + ((eq (aref alt 6) :natural) (setf (aref alt 6) :sharp)))))) + +(defmethod more-flats ((sig key-signature) &optional (n 1)) + (let ((alt (alterations sig))) + (loop repeat n + do (cond ((eq (aref alt 6) :sharp) (setf (aref alt 6) :natural)) + ((eq (aref alt 2) :sharp) (setf (aref alt 2) :natural)) + ((eq (aref alt 5) :sharp) (setf (aref alt 5) :natural)) + ((eq (aref alt 1) :sharp) (setf (aref alt 1) :natural)) + ((eq (aref alt 4) :sharp) (setf (aref alt 4) :natural)) + ((eq (aref alt 0) :sharp) (setf (aref alt 0) :natural)) + ((eq (aref alt 3) :sharp) (setf (aref alt 3) :natural)) + ((eq (aref alt 6) :natural) (setf (aref alt 6) :flat)) + ((eq (aref alt 2) :natural) (setf (aref alt 2) :flat)) + ((eq (aref alt 5) :natural) (setf (aref alt 5) :flat)) + ((eq (aref alt 1) :natural) (setf (aref alt 1) :flat)) + ((eq (aref alt 4) :natural) (setf (aref alt 4) :flat)) + ((eq (aref alt 0) :natural) (setf (aref alt 0) :flat)) + ((eq (aref alt 3) :natural) (setf (aref alt 3) :flat)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Cluster ;;; Return a list of the notes of the cluster From rstrandh at common-lisp.net Thu Feb 9 03:17:25 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Wed, 8 Feb 2006 21:17:25 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060209031725.62E324B012@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv22139 Modified Files: buffer.lisp drawing.lisp gui.lisp measure.lisp packages.lisp Log Message: The default key signature of a staff is now represented by an instance of the new class `key-signature', rather than by just a vector. The commands `com-more-sharps' and `com-more-flats' now call new protocol generic functions on the key signature. I used the suggestion from the patch by Christophe Rhodes to introduce a new class `rhythmic-element' below `element' and move slots that have to do with duration to that new class (rbeams, lbeams, dots). The `key-signature' class does not inherit from `rhythmic-element', but instead directly from `element'. In order to avoid having to alter the external format yet again, the reader tests whether a vector was read as the key signature, and if so, replaces it by an instance of the new class. As a nice side effect, I was able to remove the symbol `invalidate-everything-using-staff' from the list of exported symbols of `measure.lisp', because it is now used by the :after methods on `more-sharps' and `more-flats', defined in the same package. What I haven't done (I'll let Christophe do it, unless he takes too long) is to incorporate the parts from Christophe's patch that make it possible to insert key signatures as elements into layers. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/08 18:36:28 1.31 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/09 03:17:25 1.32 @@ -86,9 +86,16 @@ (defclass fiveline-staff (staff) ((print-character :allocation :class :initform #\=) (clef :accessor clef :initarg :clef :initform (make-clef :treble)) - (keysig :accessor keysig :initarg :keysig - :initform (make-array 7 :initial-element :natural)))) + (%keysig :accessor keysig :initarg :keysig + :initform (make-array 7 :initial-element :natural)))) +(defmethod initialize-instance :after ((obj fiveline-staff) &rest args) + (declare (ignore args)) + (with-slots (%keysig) obj + (when (vectorp %keysig) + (setf %keysig + (make-instance 'key-signature :staff obj :alterations %keysig))))) + (defun make-fiveline-staff (&rest args &key name clef keysig) (declare (ignore name clef keysig)) (apply #'make-instance 'fiveline-staff args)) @@ -219,48 +226,63 @@ ;;; currently does not belong to any bar. (defgeneric bar (element)) +(defclass element (gsharp-object) + ((bar :initform nil :initarg :bar :accessor bar) + (xoffset :initform 0 :initarg :xoffset :accessor xoffset))) + +(defmethod print-gsharp-object :after ((e element) stream) + (with-slots (notehead rbeams lbeams dots xoffset) e + (format stream + "~_:xoffset ~W " xoffset))) + +(defmethod duration ((element element)) 0) +(defmethod rbeams ((element element)) 0) +(defmethod lbeams ((element element)) 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Rhythmic element + ;;; Return the notehead of the element. With setf, set the notehead ;;; of the element. -(defgeneric notehead (element)) -(defgeneric (setf notehead) (notehead element)) +(defgeneric notehead (rhythmic-element)) +(defgeneric (setf notehead) (notehead rhythmic-element)) ;;; Return the number of right beams of the element. With setf, set ;;; the number of right beams of the element. -(defgeneric rbeams (element)) -(defgeneric (setf rbeams) (rbeams element)) +(defgeneric rbeams (rhythmic-element)) +(defgeneric (setf rbeams) (rbeams rhythmic-element)) ;;; Return the number of left beams of the element. With setf, set ;;; the number of left beams of the element. -(defgeneric lbeams (element)) -(defgeneric (setf lbeams) (lbeams element)) +(defgeneric lbeams (rhythmic-element)) +(defgeneric (setf lbeams) (lbeams rhythmic-element)) ;;; Return the number of dots of the element. With setf, set the ;;; number of dots of the element. -(defgeneric dots (element)) -(defgeneric (setf dots) (dots element)) +(defgeneric dots (rhythmic-element)) +(defgeneric (setf dots) (dots rhythmic-element)) -(defclass element (gsharp-object) - ((bar :initform nil :initarg :bar :accessor bar) - (notehead :initform :whole :initarg :notehead :accessor notehead) +(defclass rhythmic-element (element) + ((notehead :initform :whole :initarg :notehead :accessor notehead) (rbeams :initform 0 :initarg :rbeams :accessor rbeams) (lbeams :initform 0 :initarg :lbeams :accessor lbeams) - (dots :initform 0 :initarg :dots :accessor dots) - (xoffset :initform 0 :initarg :xoffset :accessor xoffset))) + (dots :initform 0 :initarg :dots :accessor dots))) -(defmethod print-gsharp-object :after ((e element) stream) - (with-slots (notehead rbeams lbeams dots xoffset) e +(defmethod print-gsharp-object :after ((e rhythmic-element) stream) + (with-slots (notehead rbeams lbeams dots) e (format stream - "~_:notehead ~W ~_:rbeams ~W ~_:lbeams ~W ~_:dots ~W ~_:xoffset ~W " - notehead rbeams lbeams dots xoffset))) + "~_:notehead ~W ~_:rbeams ~W ~_:lbeams ~W ~_:dots ~W " + notehead rbeams lbeams dots))) -(defmethod undotted-duration ((element element)) +(defmethod undotted-duration ((element rhythmic-element)) (ecase (notehead element) (:whole 1) (:half 1/2) (:filled (/ (expt 2 (+ 2 (max (rbeams element) (lbeams element)))))))) -(defmethod duration ((element element)) +(defmethod duration ((element rhythmic-element)) (let ((duration (undotted-duration element))) (do ((dot-duration (/ duration 2) (/ dot-duration 2)) (nb-dots (dots element) (1- nb-dots))) @@ -272,7 +294,7 @@ ;;; ;;; Melody element -(defclass melody-element (element) ()) +(defclass melody-element (rhythmic-element) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -292,11 +314,21 @@ (:documentation "make the key signature N alterations flatter by removing some sharps and/or adding some flats")) -(defclass key-signature (melody-element) +(defclass key-signature (element) ((%staff :initarg :staff :reader staff) (%alterations :initform (make-array 7 :initial-element :natural) :initarg :alterations :reader alterations))) +(defun make-key-signature (staff &rest args &key alterations) + (declare (type (or null (simple-vector 7)) alterations) + (ignore alterations)) + (apply #'make-instance 'key-signature :staff staff args)) + +(defmethod print-gsharp-object :after ((k key-signature) stream) + (with-slots (%staff %alterations) k + (format stream + "~_:staff ~W ~_:alterations ~W " %staff %alterations))) + (defmethod more-sharps ((sig key-signature) &optional (n 1)) (let ((alt (alterations sig))) (loop repeat n @@ -478,7 +510,7 @@ ;;; ;;; Lyrics element -(defclass lyrics-element (element) +(defclass lyrics-element (rhythmic-element) ((print-character :allocation :class :initform #\A) (staff :initarg :staff :reader staff) (text :initarg :text --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/07 04:52:06 1.60 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/09 03:17:25 1.61 @@ -47,7 +47,7 @@ (loop for pitch in '(6 2 5 1 4 0 3) for line in '(0 3 -1 2 -2 1 -3) for x from (+ x1 10 (score-pane:staff-step 8)) by (score-pane:staff-step 2) - while (eq (aref (keysig staff) pitch) :flat) + while (eq (aref (alterations (keysig staff)) pitch) :flat) do (score-pane:draw-accidental pane :flat x (+ line yoffset)))) (let ((yoffset (ecase (name (clef staff)) (:bass (lineno (clef staff))) @@ -56,7 +56,7 @@ (loop for pitch in '(3 0 4 1 5 2 6) for line in '(0 -3 1 -2 -5 -1 -4) for x from (+ x1 10 (score-pane:staff-step 8)) by (score-pane:staff-step 2.5) - while (eq (aref (keysig staff) pitch) :sharp) + while (eq (aref (alterations (keysig staff)) pitch) :sharp) do (score-pane:draw-accidental pane :sharp x (+ line yoffset))))) (present staff `((score-pane:fiveline-staff) @@ -332,13 +332,13 @@ (loop for staff in staves maximize (if (typep staff 'fiveline-staff) - (count :flat (keysig staff)) + (count :flat (alterations (keysig staff))) 0))) (* (score-pane:staff-step 2.5) (loop for staff in staves maximize (if (typep staff 'fiveline-staff) - (count :sharp (keysig staff)) + (count :sharp (alterations (keysig staff))) 0))))) (method (let ((old-method (buffer-cost-method buffer))) (make-measure-cost-method (min-width old-method) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/01/05 19:14:45 1.51 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/09 03:17:25 1.52 @@ -580,7 +580,7 @@ (staff (car (staves (layer (slice (bar cluster)))))) (note (make-note pitch staff :head (notehead state) - :accidentals (aref (keysig staff) (mod pitch 7)) + :accidentals (aref (alterations (keysig staff)) (mod pitch 7)) :dots (dots state)))) (setf *current-cluster* cluster *current-note* note) @@ -1091,42 +1091,10 @@ (remove-staff-from-layer staff layer))) (define-gsharp-command com-more-sharps () - (let ((staff (car (staves (layer (current-cursor)))))) - (invalidate-everything-using-staff (current-buffer) staff) - (let ((keysig (keysig staff))) - (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)) - ((eq (aref keysig 1) :flat) (setf (aref keysig 1) :natural)) - ((eq (aref keysig 5) :flat) (setf (aref keysig 5) :natural)) - ((eq (aref keysig 2) :flat) (setf (aref keysig 2) :natural)) - ((eq (aref keysig 6) :flat) (setf (aref keysig 6) :natural)) - ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :sharp)) - ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :sharp)) - ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :sharp)) - ((eq (aref keysig 1) :natural) (setf (aref keysig 1) :sharp)) - ((eq (aref keysig 5) :natural) (setf (aref keysig 5) :sharp)) - ((eq (aref keysig 2) :natural) (setf (aref keysig 2) :sharp)) - ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :sharp)))))) + (more-sharps (keysig (car (staves (layer (current-cursor))))))) (define-gsharp-command com-more-flats () - (let ((staff (car (staves (layer (current-cursor)))))) - (invalidate-everything-using-staff (current-buffer) staff) - (let ((keysig (keysig staff))) - (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)) - ((eq (aref keysig 1) :sharp) (setf (aref keysig 1) :natural)) - ((eq (aref keysig 4) :sharp) (setf (aref keysig 4) :natural)) - ((eq (aref keysig 0) :sharp) (setf (aref keysig 0) :natural)) - ((eq (aref keysig 3) :sharp) (setf (aref keysig 3) :natural)) - ((eq (aref keysig 6) :natural) (setf (aref keysig 6) :flat)) - ((eq (aref keysig 2) :natural) (setf (aref keysig 2) :flat)) - ((eq (aref keysig 5) :natural) (setf (aref keysig 5) :flat)) - ((eq (aref keysig 1) :natural) (setf (aref keysig 1) :flat)) - ((eq (aref keysig 4) :natural) (setf (aref keysig 4) :flat)) - ((eq (aref keysig 0) :natural) (setf (aref keysig 0) :flat)) - ((eq (aref keysig 3) :natural) (setf (aref keysig 3) :flat)))))) + (more-flats (keysig (car (staves (layer (current-cursor))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/01/25 00:50:56 1.25 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/02/09 03:17:25 1.26 @@ -8,6 +8,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Key signature + +(defmethod more-sharps :after ((sig key-signature) &optional n) + (declare (ignore n)) + (let ((staff (staff sig))) + (invalidate-everything-using-staff (buffer staff) staff))) + +(defmethod more-flats :after ((sig key-signature) &optional n) + (declare (ignore n)) + (let ((staff (staff sig))) + (invalidate-everything-using-staff (buffer staff) staff))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Staff (define-added-mixin rstaff () staff @@ -207,7 +221,7 @@ (loop for note in group do (setf (final-accidental note) (if (eq (accidentals note) - (aref (keysig (staff note)) (mod (pitch note) 7))) + (aref (alterations (keysig (staff note))) (mod (pitch note) 7))) nil (accidentals note))))) --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/01/22 20:38:52 1.41 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/09 03:17:25 1.42 @@ -100,6 +100,7 @@ #:remove-staff-from-layer #:stem-direction #:undotted-duration #:duration #:clef #:keysig #:staff-pos #:xoffset #:read-everything #:save-buffer-to-stream + #:key-signature #:alterations #:more-sharps #:more-flats #:line-width #:min-width #:spacing-style #:right-edge #:left-offset #:left-margin #:text #:append-char #:erase-char )) @@ -137,8 +138,7 @@ #:group-notes-by-staff #:final-relative-note-xoffset #:final-accidental #:final-relative-accidental-xoffset #:timeline #:timelines #:elasticity - #:smallest-gap #:elasticity-function - #:invalidate-everything-using-staff)) + #:smallest-gap #:elasticity-function)) (defpackage :gsharp-postscript (:use :clim :clim-lisp) From rstrandh at common-lisp.net Mon Feb 13 23:51:34 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 13 Feb 2006 17:51:34 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060213235134.EA2BA2A034@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv26626 Modified Files: buffer.lisp gui.lisp modes.lisp packages.lisp Log Message: Reorganized the command tables so that there are command tables that are specific to element types. Implemented find-applicable-gsharp-command-table that determines a command table based on the layer the cursor is in and (if any) the current element. Added `tie-left' and `tie-right' accessors to notes and lyrics elements and commands for modifying the ties. Ties are not rendered yet. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/09 03:17:25 1.32 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/13 23:51:34 1.33 @@ -183,7 +183,9 @@ :type (member :natural :flat :double-flat :sharp :double-sharp)) (dots :initform nil :initarg :dots :reader dots - :type (or (integer 0 3) null)))) + :type (or (integer 0 3) null)) + (%tie-right :initform nil :initarg :tie-right :accessor tie-right) + (%tie-left :initform nil :initarg :tie-left :accessor tie-left))) (defun make-note (pitch staff &rest args &key head (accidentals :natural) dots) (declare (type (integer 0 127) pitch) @@ -515,7 +517,9 @@ (staff :initarg :staff :reader staff) (text :initarg :text :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0) - :reader text))) + :reader text) + (%tie-right :initform nil :initarg :tie-right :accessor tie-right) + (%tie-left :initform nil :initarg :tie-left :accessor tie-left))) (defmethod initialize-instance :after ((elem lyrics-element) &rest args) (declare (ignore args)) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/09 03:17:25 1.52 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/13 23:51:34 1.53 @@ -14,6 +14,8 @@ (define-command-table total-melody-table :inherit-from (melody-table global-gsharp-table gsharp)) +(define-command-table total-cluster-table + :inherit-from (cluster-table melody-table global-gsharp-table gsharp)) (define-command-table total-lyrics-table :inherit-from (lyrics-table global-gsharp-table gsharp)) @@ -410,12 +412,24 @@ (declare (ignore string)) (if success layer (error 'no-such-layer)))) +(defgeneric find-applicable-gsharp-command-table (layer element)) + +(defmethod find-applicable-gsharp-command-table ((layer melody-layer) element) + (declare (ignore element)) + (find-command-table 'total-melody-table)) + +(defmethod find-applicable-gsharp-command-table ((layer melody-layer) (element cluster)) + (find-command-table 'total-cluster-table)) + +(defmethod find-applicable-gsharp-command-table ((layer lyrics-layer) element) + (declare (ignore element)) + (find-command-table 'total-lyrics-table)) + (defmethod find-applicable-command-table ((frame gsharp)) - (let* ((layer (layer (current-cursor)))) - ;; F-A-C-T-WITH-LAYER? - (typecase layer - (lyrics-layer (find-command-table 'total-lyrics-table)) - (melody-layer (find-command-table 'total-melody-table))))) + (let* ((cursor (current-cursor)) + (layer (layer cursor)) + (element (if (beginning-of-bar-p cursor) nil (current-element cursor)))) + (find-applicable-gsharp-command-table layer element))) (define-gsharp-command (com-select-layer :name t) () (let ((selected-layer (accept 'layer :prompt "Select layer"))) @@ -825,6 +839,26 @@ (unless *current-note* (com-erase-element))))) +(define-gsharp-command com-tie-note-left () + (let ((note (cur-note))) + (when note + (setf (tie-left note) t)))) + +(define-gsharp-command com-untie-note-left () + (let ((note (cur-note))) + (when note + (setf (tie-left note) nil)))) + +(define-gsharp-command com-tie-note-right () + (let ((note (cur-note))) + (when note + (setf (tie-right note) t)))) + +(define-gsharp-command com-untie-note-right () + (let ((note (cur-note))) + (when note + (setf (tie-right note) nil)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; motion by element --- /project/gsharp/cvsroot/gsharp/modes.lisp 2005/10/28 17:20:30 1.7 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/13 23:51:34 1.8 @@ -14,8 +14,17 @@ (set-key 'com-right 'global-gsharp-table '((#\r :meta))) (set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control))) (set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control))) +(set-key 'com-istate-more-dots 'global-gsharp-table '((#\i) (#\.))) +(set-key 'com-istate-more-lbeams 'global-gsharp-table '((#\i) (#\[))) +(set-key 'com-istate-more-rbeams 'global-gsharp-table '((#\i) (#\]))) +(set-key 'com-istate-rotate-notehead 'global-gsharp-table '((#\i) (#\h))) +(set-key 'com-istate-rotate-stem-direction 'global-gsharp-table '((#\i) (#\s))) +(set-key 'com-istate-fewer-dots 'global-gsharp-table '((#\i) (#\x) (#\.))) +(set-key 'com-istate-fewer-lbeams 'global-gsharp-table '((#\i) (#\x) (#\[))) +(set-key 'com-istate-fewer-rbeams 'global-gsharp-table '((#\i) (#\x) (#\]))) -;;; melody table +;;; the melody table contains commands that are specific to the +;;; melody layer (define-command-table melody-table) @@ -30,36 +39,38 @@ (set-key 'com-insert-note-g 'melody-table '(#\g)) (set-key 'com-insert-rest 'melody-table '((#\,))) (set-key 'com-insert-empty-cluster 'melody-table '((#\Space))) -(set-key 'com-add-note-c 'melody-table '(#\C)) -(set-key 'com-add-note-d 'melody-table '(#\D)) -(set-key 'com-add-note-e 'melody-table '(#\E)) -(set-key 'com-add-note-f 'melody-table '(#\F)) -(set-key 'com-add-note-g 'melody-table '(#\G)) -(set-key 'com-add-note-a 'melody-table '(#\A)) -(set-key 'com-add-note-b 'melody-table '(#\B)) (set-key 'com-current-increment 'melody-table '((#\p))) (set-key 'com-current-decrement 'melody-table '((#\n))) -(set-key 'com-istate-more-dots 'melody-table '((#\i) (#\.))) -(set-key 'com-istate-more-lbeams 'melody-table '((#\i) (#\[))) -(set-key 'com-istate-more-rbeams 'melody-table '((#\i) (#\]))) -(set-key 'com-istate-rotate-notehead 'melody-table '((#\i) (#\h))) -(set-key 'com-istate-rotate-stem-direction 'melody-table '((#\i) (#\s))) -(set-key 'com-istate-fewer-dots 'melody-table '((#\i) (#\x) (#\.))) -(set-key 'com-istate-fewer-lbeams 'melody-table '((#\i) (#\x) (#\[))) -(set-key 'com-istate-fewer-rbeams 'melody-table '((#\i) (#\x) (#\]))) (set-key 'com-fewer-dots 'melody-table '((#\x) (#\.))) (set-key 'com-fewer-lbeams 'melody-table '((#\x) (#\[))) (set-key 'com-fewer-rbeams 'melody-table '((#\x) (#\]))) (set-key 'com-erase-element 'melody-table '((#\h :control))) (set-key 'com-rotate-notehead 'melody-table '((#\h :meta))) (set-key 'com-rotate-stem-direction 'melody-table '((#\s :meta))) -(set-key 'com-sharper 'melody-table '((#\#))) -(set-key 'com-flatter 'melody-table '(#\@)) (set-key 'com-more-sharps 'melody-table '((#\# :meta))) (set-key 'com-more-sharps 'melody-table '((#\# :meta :shift))) (set-key 'com-more-flats 'melody-table '((#\@ :meta :shift))) -(set-key 'com-up 'melody-table '((#\u :meta))) -(set-key 'com-down 'melody-table '((#\d :meta))) + +;;; the cluster table contains commands that are specific to +;;; clusters + +(define-command-table cluster-table) + +(set-key 'com-sharper 'cluster-table '((#\#))) +(set-key 'com-flatter 'cluster-table '(#\@)) +(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)) +(set-key 'com-add-note-f 'cluster-table '(#\F)) +(set-key 'com-add-note-g 'cluster-table '(#\G)) +(set-key 'com-add-note-a 'cluster-table '(#\A)) +(set-key 'com-add-note-b 'cluster-table '(#\B)) +(set-key 'com-up 'cluster-table '((#\u :meta))) +(set-key 'com-down 'cluster-table '((#\d :meta))) +(set-key 'com-tie-note-left 'cluster-table '((#\{))) +(set-key 'com-tie-note-right 'cluster-table '((#\}))) +(set-key 'com-untie-note-left 'cluster-table '((#\x) (#\{))) +(set-key 'com-untie-note-right 'cluster-table '((#\x) (#\}))) ;;; lyrics mode table --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/09 03:17:25 1.42 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/13 23:51:34 1.43 @@ -103,6 +103,7 @@ #:key-signature #:alterations #:more-sharps #:more-flats #:line-width #:min-width #:spacing-style #:right-edge #:left-offset #:left-margin #:text #:append-char #:erase-char + #:tie-right #:tie-left )) (defpackage :gsharp-numbering From rstrandh at common-lisp.net Tue Feb 14 03:00:52 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 13 Feb 2006 21:00:52 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060214030052.404B373010@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv15314 Modified Files: drawing.lisp packages.lisp score-pane.lisp Log Message: The code for drawing ties is almost finished. However, since I don't have my copy of Ross handy, I don't know the rules for the placement of ties, so for now, only a blue line between the tied notes is drawn. This is obviously wrong, but makes it possible to verify that the code works. Also, we don't draw a tie if the tied notes are on different lines. --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/09 03:17:25 1.61 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/14 03:00:52 1.62 @@ -321,9 +321,37 @@ do (compute-measure-coordinates measure x y force) do (incf x (size-at-force (elasticity-function measure) force)))) +;;; draw the ties in BARS starting at BAR and at most LENGTH bars +(defun draw-ties (pane bars bar length) + (loop until (eq bar (car bars)) + do (pop bars)) + (score-pane:with-vertical-score-position + (pane (system-y-position (car bars))) + (loop with elements = (mapcan (lambda (bar) (copy-seq (elements bar))) + (loop for bar in bars + repeat length + collect bar)) + for (e1 e2) on elements + do (when (and (typep e1 'cluster) (typep e2 'cluster) (not (null e2))) + (loop for n1 in (notes e1) + do (when (tie-right n1) + (loop for n2 in (notes e2) + do (when (and (tie-left n2) + (= (pitch n1) (pitch n2)) + (eq (staff n1) (staff n2)) + (accidentals n1) (accidentals n2)) + (let ((x1 (final-absolute-note-xoffset n1)) + (x2 (final-absolute-note-xoffset n2)) + (y (- (score-pane:staff-step (note-position n1))))) + (score-pane:with-vertical-score-position (pane (staff-yoffset (staff n1))) + (score-pane:draw-tie pane x1 x2 y))))))))))) + (defun draw-system (pane measures) (loop for measure in measures do - (draw-measure pane measure))) + (draw-measure pane measure)) + (loop with length = (length measures) + for bar in (measure-bars (car measures)) + do (draw-ties pane (bars (slice bar)) bar length))) (defmethod draw-buffer (pane (buffer buffer) *cursor* x y) (score-pane:with-staff-size 6 --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/13 23:51:34 1.43 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/14 03:00:52 1.44 @@ -55,6 +55,7 @@ #: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 + #:draw-tie #:with-score-pane #:with-vertical-score-position #:with-staff-size #:with-notehead-right-offsets #:with-suspended-note-offset --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/01/04 19:08:12 1.19 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/02/14 03:00:52 1.20 @@ -627,6 +627,10 @@ (draw-horizontal-beam pane xx1 y1 xx2) (draw-sloped-beam medium xx1 y1 xx2 y2)))))) +;;; FIXME obviously +(defun draw-tie (pane x1 x2 y) + (draw-rectangle* pane x1 (1- y) x2 (1+ y) :ink +blue+)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; convenience macros From rstrandh at common-lisp.net Tue Feb 14 18:16:03 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 14 Feb 2006 12:16:03 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060214181603.E515066015@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv26590 Modified Files: play.lisp Log Message: Make it easier for timidity to find its argument. --- /project/gsharp/cvsroot/gsharp/play.lisp 2005/10/31 02:16:27 1.2 +++ /project/gsharp/cvsroot/gsharp/play.lisp 2006/02/14 18:16:03 1.3 @@ -57,11 +57,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"))) From rstrandh at common-lisp.net Wed Feb 15 02:44:48 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 14 Feb 2006 20:44:48 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060215024448.B874D70007@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv22978 Modified Files: measure.lisp Log Message: Added an :after method to the append-char generic-function so that the buffer is marked as modified when lyrics change. --- /project/gsharp/cvsroot/gsharp/measure.lisp 2006/02/09 03:17:25 1.26 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2006/02/15 02:44:48 1.27 @@ -113,6 +113,10 @@ (declare (ignore direction)) (mark-modified element)) +(defmethod append-char :after ((element lyrics-element) char) + (declare (ignore char)) + (mark-modified element)) + (defmethod note-position ((note note)) (let ((clef (clef (staff note)))) (+ (- (pitch note) @@ -763,7 +767,8 @@ (1- (nb-measures (segmentno buf (1- (nb-segments buf))))))) (defmethod mark-modified ((buffer rbuffer)) - (setf (modified-p buffer) t)) + (setf (modified-p buffer) t) + (setf (needs-saving buffer) t)) (defmethod add-segment :after ((segment segment) (buffer rbuffer) position) (declare (ignore position)) From rstrandh at common-lisp.net Wed Feb 15 02:54:28 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 14 Feb 2006 20:54:28 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060215025428.BC1A275009@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv24313 Modified Files: buffer.lisp gsharp.asd gui.lisp modes.lisp packages.lisp Added Files: esa-buffer.lisp esa-io.lisp Log Message: Added a new package and a new file ESA-BUFFER allowing buffers to be named, to be associated with a file name, and to have a `needs-saving' and a `read-only' flag. Added a new package and a new file ESA-IO containing application-independent functionality to create buffers from files, and to save buffers to files. This package also supplies filename completion. Most of the code was adapted from Climacs. Abstracted out all Gsharp-specific I/O to ESA-IO. In particular, this means that we now have commands such as C-x C-s, and C-x C-w, which we didn't before. The old I/O code is still there. Cleanup is next. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/13 23:51:34 1.33 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/15 02:54:26 1.34 @@ -1042,7 +1042,7 @@ (defvar *default-left-offset* 30) (defvar *default-left-margin* 20) -(defclass buffer (gsharp-object) +(defclass buffer (gsharp-object esa-buffer-mixin) ((print-character :allocation :class :initform #\B) (segments :initform '() :initarg :segments :accessor segments) (staves :initform (list (make-fiveline-staff)) @@ -1214,7 +1214,15 @@ (*readtable* readtable)) (read stream))))) -(defun save-buffer-to-stream (buffer stream) +(defun read-buffer-from-stream (stream) + (let* ((version (read-line stream)) + (readtable (cdr (assoc version *readtables* :test #'string=)))) + (assert readtable () 'unknown-file-version) + (let ((*read-eval* nil) + (*readtable* readtable)) + (read stream)))) + +(defmethod save-buffer-to-stream ((buffer buffer) stream) (let ((*print-circle* t) (*package* (find-package :keyword))) ;; (format stream "G#V3~%") --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2005/12/07 03:38:27 1.5 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/02/15 02:54:26 1.6 @@ -24,6 +24,8 @@ "packages" "clim-patches" "esa" + "esa-buffer" + "esa-io" "utilities" "gf" "sdl" --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/13 23:51:34 1.53 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/15 02:54:26 1.54 @@ -68,8 +68,11 @@ interactor))) (:top-level (esa-top-level))) -(defun current-buffer () - (buffer (view (car (windows *application-frame*))))) +(defmethod buffers ((application-frame gsharp)) + (remove-duplicates (mapcar #'buffer (views application-frame)) :test #'eq)) + +(defmethod current-buffer ((application-frame gsharp)) + (buffer (view (car (windows application-frame))))) (defun current-cursor () (cursor (view (car (windows *application-frame*))))) @@ -308,13 +311,26 @@ (setf (input-state *application-frame*) input-state) (select-layer cursor (car (layers (segment (current-cursor))))))) +(defmethod find-file :around (filepath (application-frame gsharp)) + (declare (ignore filepath)) + (let* ((buffer (call-next-method)) + (input-state (make-input-state)) + (cursor (make-initial-cursor buffer)) + (view (make-instance 'orchestra-view + :buffer buffer + :cursor cursor))) + (setf (view (car (windows *application-frame*))) view + (input-state *application-frame*) input-state + (filepath buffer) filepath) + (select-layer cursor (car (layers (segment (current-cursor))))))) + (define-gsharp-command (com-save-buffer-as :name t) () (let* ((stream (frame-standard-input *application-frame*)) (filename (handler-case (accept 'completable-pathname :stream stream :prompt "File Name") (simple-parse-error () (error 'file-not-found))))) (with-open-file (stream filename :direction :output) - (save-buffer-to-stream (current-buffer) stream) + (save-buffer-to-stream (current-buffer *application-frame*) stream) (message "Saved buffer to ~A~%" filename)))) (define-gsharp-command (com-quit :name t) () @@ -354,13 +370,13 @@ (define-gsharp-command (com-insert-segment-before :name t) () (let ((cursor (current-cursor))) - (insert-segment-before (make-instance 'segment :staff (car (staves (current-buffer)))) + (insert-segment-before (make-instance 'segment :staff (car (staves (current-buffer *application-frame*)))) cursor) (backward-segment cursor))) (define-gsharp-command (com-insert-segment-after :name t) () (let ((cursor (current-cursor))) - (insert-segment-after (make-instance 'segment :staff (car (staves (current-buffer)))) + (insert-segment-after (make-instance 'segment :staff (car (staves (current-buffer *application-frame*)))) cursor) (forward-segment cursor))) @@ -996,7 +1012,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (staves (current-buffer)) + (staves (current-buffer *application-frame*)) '() :action mode :predicate (constantly t) @@ -1013,7 +1029,7 @@ (lambda (so-far mode) (complete-from-possibilities so-far - (staves (current-buffer)) + (staves (current-buffer *application-frame*)) '() :action mode :predicate (lambda (obj) (typep obj 'fiveline-staff)) @@ -1080,7 +1096,7 @@ (defun acquire-unique-staff-name (prompt) (let ((name (accept 'string :prompt prompt))) - (assert (not (member name (staves (current-buffer)) :test #'string= :key #'name)) + (assert (not (member name (staves (current-buffer *application-frame*)) :test #'string= :key #'name)) () `staff-name-not-unique) name)) @@ -1096,21 +1112,21 @@ (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) - (current-buffer))) + (current-buffer *application-frame*))) (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) - (current-buffer))) + (current-buffer *application-frame*))) (define-gsharp-command (com-delete-staff :name t) () (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff") - (current-buffer))) + (current-buffer *application-frame*))) (define-gsharp-command (com-rename-staff :name t) () (let* ((staff (accept 'score-pane:staff :prompt "Rename staff")) (name (acquire-unique-staff-name "New name of staff")) - (buffer (current-buffer))) + (buffer (current-buffer *application-frame*))) (rename-staff name staff buffer))) (define-gsharp-command (com-add-staff-to-layer :name t) () @@ -1145,3 +1161,13 @@ (insert-element element cursor) (forward-element cursor) element)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; I/O + +(defmethod make-buffer-from-stream (stream (frame gsharp)) + (read-buffer-from-stream stream)) + +(defmethod make-new-buffer ((frame gsharp)) + (make-instance 'buffer)) \ No newline at end of file --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/13 23:51:34 1.8 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/15 02:54:26 1.9 @@ -1,7 +1,7 @@ (in-package :gsharp) (define-command-table global-gsharp-table - :inherit-from (global-esa-table keyboard-macro-table)) + :inherit-from (global-esa-table esa-io-table keyboard-macro-table)) (set-key `(com-forward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\f :control))) (set-key `(com-backward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\b :control))) @@ -13,7 +13,7 @@ (set-key 'com-left 'global-gsharp-table '((#\l :meta))) (set-key 'com-right 'global-gsharp-table '((#\r :meta))) (set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control))) -(set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control))) +;;; (set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control))) (set-key 'com-istate-more-dots 'global-gsharp-table '((#\i) (#\.))) (set-key 'com-istate-more-lbeams 'global-gsharp-table '((#\i) (#\[))) (set-key 'com-istate-more-rbeams 'global-gsharp-table '((#\i) (#\]))) --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/14 03:00:52 1.44 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/15 02:54:27 1.45 @@ -11,6 +11,22 @@ #:set-key #:find-applicable-command-table)) +(defpackage :esa-buffer + (:use :clim-lisp :clim :esa) + (:export #:make-buffer-from-stream #:save-buffer-to-stream + #:filepath #:name #:needs-saving + #:esa-buffer-mixin + #:make-new-buffer + #:read-only-p)) + +(defpackage :esa-io + (:use :clim-lisp :clim :esa :esa-buffer) + (:export #:buffers #:current-buffer + #:find-file #:find-file-read-only + #:set-visited-filename + #:save-buffer #:write-buffer + #:esa-io-table)) + (defpackage :gsharp-utilities (:shadow built-in-class) (:use :clim-lisp :clim-mop) @@ -64,7 +80,7 @@ #:score-view)) (defpackage :gsharp-buffer - (:use :common-lisp :gsharp-utilities) + (:use :common-lisp :gsharp-utilities :esa-buffer) (:shadow #:rest) (:export #:clef #:name #:lineno #:make-clef #:staff #:fiveline-staff #:make-fiveline-staff @@ -100,12 +116,13 @@ #:add-staff-to-layer #:remove-staff-from-layer #:stem-direction #:undotted-duration #:duration - #:clef #:keysig #:staff-pos #:xoffset #:read-everything #:save-buffer-to-stream + #:clef #:keysig #:staff-pos #:xoffset #:read-everything + #:read-buffer-from-stream #:key-signature #:alterations #:more-sharps #:more-flats #:line-width #:min-width #:spacing-style #:right-edge #:left-offset #:left-margin #:text #:append-char #:erase-char #:tie-right #:tie-left - )) + #:needs-saving)) (defpackage :gsharp-numbering (:use :gsharp-utilities :gsharp-buffer :clim-lisp) @@ -226,7 +243,7 @@ #:play-buffer)) (defpackage :gsharp - (:use :clim :clim-lisp :gsharp-utilities :esa + (:use :clim :clim-lisp :gsharp-utilities :esa :esa-buffer :esa-io :gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering :gsharp-measure :sdl :midi :gsharp-play) --- /project/gsharp/cvsroot/gsharp/esa-buffer.lisp 2006/02/15 02:54:28 NONE +++ /project/gsharp/cvsroot/gsharp/esa-buffer.lisp 2006/02/15 02:54:28 1.1 ;;; -*- Mode: Lisp; Package: ESA-IO -*- ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh at labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :esa-buffer) (defgeneric make-buffer-from-stream (stream application-frame) (:documentation "Create a fresh buffer by reading the external representation from STREAM")) (defgeneric make-new-buffer (application-frame) (:documentation "Create a empty buffer for the application frame")) (defgeneric save-buffer-to-stream (buffer stream) (:documentation "Save the entire BUFFER to STREAM in the appropriate external representation")) (defgeneric filepath (buffer)) (defgeneric (setf filepath) (filepath buffer)) (defgeneric name (buffer)) (defgeneric (setf name) (name buffer)) (defgeneric needs-saving (buffer)) (defgeneric (setf needs-saving) (needs-saving buffer)) (defclass esa-buffer-mixin () ((%filepath :initform nil :accessor filepath) (%name :initarg :name :initform "*scratch*" :accessor name) (%needs-saving :initform nil :accessor needs-saving) (%read-only-p :initform nil :accessor read-only-p))) --- /project/gsharp/cvsroot/gsharp/esa-io.lisp 2006/02/15 02:54:28 NONE +++ /project/gsharp/cvsroot/gsharp/esa-io.lisp 2006/02/15 02:54:28 1.1 ;;; -*- Mode: Lisp; Package: ESA-IO -*- ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh at labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :esa-io) (defgeneric buffers (application-frame) (:documentation "Return a list of all the buffers of the application")) (defgeneric current-buffer (application-frame) (:documentation "Return the current buffer of APPLICATION-FRAME")) (defgeneric find-file (file-path application-frame)) (defgeneric find-file-read-only (file-path application-frame)) (defgeneric set-visited-filename (filepath buffer application-frame)) (defgeneric save-buffer (buffer application-frame)) (defgeneric write-buffer (buffer filepath application-frame)) (make-command-table 'esa-io-table :errorp nil) (defgeneric find-file (file-path application-frame) (:documentation "if a buffer with the file-path already exists, return it, else if a file with the right name exists, return a fresh buffer created from the file, else return a new empty buffer having the associated file name.")) (defun filename-completer (so-far mode) (flet ((remove-trail (s) (subseq s 0 (let ((pos (position #\/ s :from-end t))) (if pos (1+ pos) 0))))) (let* ((directory-prefix (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) "" (namestring #+sbcl *default-pathname-defaults* #+cmu (ext:default-directory) #-(or sbcl cmu) *default-pathname-defaults*))) (full-so-far (concatenate 'string directory-prefix so-far)) (pathnames (loop with length = (length full-so-far) and wildcard = (concatenate 'string (remove-trail so-far) "*.*") for path in #+(or sbcl cmu lispworks) (directory wildcard) #+openmcl (directory wildcard :directories t) #+allegro (directory wildcard :directories-are-files nil) #+cormanlisp (nconc (directory wildcard) (cl::directory-subdirs dirname)) #-(or sbcl cmu lispworks openmcl allegro cormanlisp) (directory wildcard) when (let ((mismatch (mismatch (namestring path) full-so-far))) (or (null mismatch) (= mismatch length))) collect path)) (strings (mapcar #'namestring pathnames)) (first-string (car strings)) (length-common-prefix nil) (completed-string nil) (full-completed-string nil)) (unless (null pathnames) (setf length-common-prefix (loop with length = (length first-string) for string in (cdr strings) do (setf length (min length (or (mismatch string first-string) length))) finally (return length)))) (unless (null pathnames) (setf completed-string (subseq first-string (length directory-prefix) (if (null (cdr pathnames)) nil length-common-prefix))) (setf full-completed-string (concatenate 'string directory-prefix completed-string))) (case mode ((:complete-limited :complete-maximal) (cond ((null pathnames) (values so-far nil nil 0 nil)) ((null (cdr pathnames)) (values completed-string t (car pathnames) 1 nil)) (t (values completed-string nil nil (length pathnames) nil)))) (:complete (cond ((null pathnames) (values so-far t so-far 1 nil)) ((null (cdr pathnames)) (values completed-string t (car pathnames) 1 nil)) ((find full-completed-string strings :test #'string-equal) (let ((pos (position full-completed-string strings :test #'string-equal))) (values completed-string t (elt pathnames pos) (length pathnames) nil))) (t (values completed-string nil nil (length pathnames) nil)))) (:possibilities (values nil nil nil (length pathnames) (loop with length = (length directory-prefix) for name in pathnames collect (list (subseq (namestring name) length nil) name)))))))) (define-presentation-method present (object (type pathname) stream (view textual-view) &key) (princ (namestring object) stream)) (define-presentation-method accept ((type pathname) stream (view textual-view) &key (default nil defaultp) (default-type type)) (multiple-value-bind (pathname success string) (complete-input stream #'filename-completer :allow-any-input t) (cond (success (values pathname type)) ((and (zerop (length string)) defaultp) (values default default-type)) (t (values string 'string))))) ;;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC does not designate a directory." (let ((name (pathname-name pathspec)) (type (pathname-type pathspec))) (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific))))) (defun filepath-filename (pathname) (if (null (pathname-type pathname)) (pathname-name pathname) (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) (defmethod find-file (filepath application-frame) (cond ((null filepath) (display-message "No file name given.") (beep)) ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath) (beep)) (t (or (find filepath (buffers *application-frame*) :key #'filepath :test #'equal) (let ((buffer (if (probe-file filepath) (with-open-file (stream filepath :direction :input) (make-buffer-from-stream stream *application-frame*)) (make-new-buffer *application-frame*)))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) buffer))))) (define-command (com-find-file :name t :command-table esa-io-table) () (let* ((filepath (accept 'pathname :prompt "Find File"))) (find-file filepath *application-frame*))) (set-key 'com-find-file 'esa-io-table '((#\x :control) (#\f :control))) (defmethod find-file-read-only (filepath application-frame) (cond ((null filepath) (display-message "No file name given.") (beep)) ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath) (beep)) (t (or (find filepath (buffers *application-frame*) :key #'filepath :test #'equal) (if (probe-file filepath) (with-open-file (stream filepath :direction :input) (let ((buffer (make-buffer-from-stream stream *application-frame*))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (read-only-p buffer) t (needs-saving buffer) nil))) (progn (display-message "No such file: ~A" filepath) (beep) nil)))))) (define-command (com-find-file-read-only :name t :command-table esa-io-table) () (let ((filepath (accept 'pathname :Prompt "Find file read only"))) (find-file-read-only filepath *application-frame*))) (set-key 'com-find-file-read-only 'esa-io-table '((#\x :control) (#\r :control))) (define-command (com-read-only :name t :command-table esa-io-table) () (let ((buffer (current-buffer *application-frame*))) (setf (read-only-p buffer) (not (read-only-p buffer))))) (set-key 'com-read-only 'esa-io-table '((#\x :control) (#\q :control))) (defmethod set-visited-file-name (filename buffer application-frame) (setf (filepath buffer) filename (name buffer) (filepath-filename filename) (needs-saving buffer) t)) (define-command (com-set-visited-file-name :name t :command-table esa-io-table) () (let ((filename (accept 'pathname :prompt "New file name"))) (set-visited-file-name filename (current-buffer *application-frame*) *application-frame*))) (defmethod save-buffer (buffer application-frame) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) (cond ((directory-pathname-p filepath) (display-message "~A is a directory." filepath) (beep)) (t (when (probe-file filepath) (let ((backup-name (pathname-name filepath)) (backup-type (concatenate 'string (pathname-type filepath) "~"))) (rename-file filepath (make-pathname :name backup-name :type backup-type)))) (with-open-file (stream filepath :direction :output :if-exists :supersede) (save-buffer-to-stream buffer stream)) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath)) (display-message "Wrote: ~a" (filepath buffer)) (setf (needs-saving buffer) nil))))) (define-command (com-save-buffer :name t :command-table esa-io-table) () (let ((buffer (current-buffer *application-frame*))) (if (or (null (filepath buffer)) (needs-saving buffer)) (save-buffer buffer *application-frame*) (display-message "No changes need to be saved from ~a" (name buffer))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) (defmethod write-buffer (buffer filepath application-frame) (cond ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath)) (t (with-open-file (stream filepath :direction :output :if-exists :supersede) (save-buffer-to-stream buffer stream)) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) (display-message "Wrote: ~a" (filepath buffer))))) (define-command (com-write-buffer :name t :command-table esa-io-table) () (let ((filepath (accept 'pathname :prompt "Write Buffer to File")) (buffer (current-buffer *application-frame*))) (write-buffer buffer filepath *application-frame*))) (set-key 'com-write-buffer 'esa-io-table '((#\x :control) (#\w :control))) From rstrandh at common-lisp.net Wed Feb 15 03:18:03 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 14 Feb 2006 21:18:03 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060215031803.B6F6F43010@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv29109 Modified Files: gui.lisp modes.lisp Log Message: Cleaned up some dead code. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/15 02:54:26 1.54 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/15 03:18:03 1.55 @@ -198,9 +198,9 @@ (make-command-table 'file-command-table :errorp nil - :menu '(("Load" :command com-load-file) + :menu '(("Find" :command com-find-file) ("Save" :command com-save-buffer) - ("Save as" :command com-save-buffer-as) + ("Save as" :command com-write-buffer) ("Quit" :command com-quit))) (define-gsharp-command (com-new-buffer :name t) () @@ -216,101 +216,6 @@ (setf (input-state *application-frame*) input-state (staves (car (layers (car (segments buffer))))) (list staff)))) -(define-presentation-type completable-pathname () - :inherit-from 'pathname) - -(define-condition file-not-found (gsharp-condition) () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "File nont found")))) - -(defun filename-completer (so-far mode) - (flet ((remove-trail (s) - (subseq s 0 (let ((pos (position #\/ s :from-end t))) - (if pos (1+ pos) 0))))) - (let* ((directory-prefix - (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) - "" - (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory)))) - (full-so-far (concatenate 'string directory-prefix so-far)) - (pathnames - (loop with length = (length full-so-far) - for path in (directory (concatenate 'string - (remove-trail so-far) - "*.*")) - when (let ((mismatch (mismatch (namestring path) full-so-far))) - (or (null mismatch) (= mismatch length))) - collect path)) - (strings (mapcar #'namestring pathnames)) - (first-string (car strings)) - (length-common-prefix nil) - (completed-string nil) - (full-completed-string nil)) - (unless (null pathnames) - (setf length-common-prefix - (loop with length = (length first-string) - for string in (cdr strings) - do (setf length (min length (or (mismatch string first-string) length))) - finally (return length)))) - (unless (null pathnames) - (setf completed-string - (subseq first-string (length directory-prefix) - (if (null (cdr pathnames)) nil length-common-prefix))) - (setf full-completed-string - (concatenate 'string directory-prefix completed-string))) - (case mode - ((:complete-limited :complete-maximal) - (cond ((null pathnames) - (values so-far nil nil 0 nil)) - ((null (cdr pathnames)) - (values completed-string t (car pathnames) 1 nil)) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:complete - (cond ((null pathnames) - (values so-far nil nil 0 nil)) - ((null (cdr pathnames)) - (values completed-string t (car pathnames) 1 nil)) - ((find full-completed-string strings :test #'string-equal) - (let ((pos (position full-completed-string strings :test #'string-equal))) - (values completed-string - t (elt pathnames pos) (length pathnames) nil))) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:possibilities - (values nil nil nil (length pathnames) - (loop with length = (length directory-prefix) - for name in pathnames - collect (list (subseq (namestring name) length nil) - name)))))))) - - -(define-presentation-method accept - ((type completable-pathname) stream (view textual-view) &key) - (multiple-value-bind (pathname success string) - (complete-input stream - #'filename-completer - :partial-completers '(#\Space) - :allow-any-input t) - (declare (ignore success)) - (or pathname string))) - -(define-gsharp-command (com-load-file :name t) () - (let* ((stream (frame-standard-input *application-frame*)) - (filename (handler-case (accept 'completable-pathname :stream stream - :prompt "File Name") - (simple-parse-error () (error 'file-not-found)))) - (buffer (read-everything filename)) - (input-state (make-input-state)) - (cursor (make-initial-cursor buffer)) - (view (make-instance 'orchestra-view - :buffer buffer - :cursor cursor))) - (setf (view (car (windows *application-frame*))) view) - (setf (input-state *application-frame*) input-state) - (select-layer cursor (car (layers (segment (current-cursor))))))) - (defmethod find-file :around (filepath (application-frame gsharp)) (declare (ignore filepath)) (let* ((buffer (call-next-method)) @@ -324,15 +229,6 @@ (filepath buffer) filepath) (select-layer cursor (car (layers (segment (current-cursor))))))) -(define-gsharp-command (com-save-buffer-as :name t) () - (let* ((stream (frame-standard-input *application-frame*)) - (filename (handler-case (accept 'completable-pathname :stream stream - :prompt "File Name") - (simple-parse-error () (error 'file-not-found))))) - (with-open-file (stream filename :direction :output) - (save-buffer-to-stream (current-buffer *application-frame*) stream) - (message "Saved buffer to ~A~%" filename)))) - (define-gsharp-command (com-quit :name t) () (frame-exit *application-frame*)) --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/15 02:54:26 1.9 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/15 03:18:03 1.10 @@ -13,7 +13,6 @@ (set-key 'com-left 'global-gsharp-table '((#\l :meta))) (set-key 'com-right 'global-gsharp-table '((#\r :meta))) (set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control))) -;;; (set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control))) (set-key 'com-istate-more-dots 'global-gsharp-table '((#\i) (#\.))) (set-key 'com-istate-more-lbeams 'global-gsharp-table '((#\i) (#\[))) (set-key 'com-istate-more-rbeams 'global-gsharp-table '((#\i) (#\]))) From rstrandh at common-lisp.net Wed Feb 15 03:36:25 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 14 Feb 2006 21:36:25 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp/Scores Message-ID: <20060215033625.7BDE24B011@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Scores In directory common-lisp:/tmp/cvs-serv30685 Added Files: fiji.gsh Log Message: An attempt to engrave a horrible tune heard on a commercial for Air Pacific on NZ TV. It is not complete yet, but you get the idea. --- /project/gsharp/cvsroot/gsharp/Scores/fiji.gsh 2006/02/15 03:36:25 NONE +++ /project/gsharp/cvsroot/gsharp/Scores/fiji.gsh 2006/02/15 03:36:25 1.1 G#V4 [GSHARP-BUFFER:BUFFER :min-width 17 :spacing-style 0.4 :right-edge 700 :left-offset 30 :left-margin 20 :staves (#1=[GSHARP-BUFFER:FIVELINE-STAFF :name "default staff" :clef [GSHARP-BUFFER:CLEF :name :TREBLE :lineno 2 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #1# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL) ] ] #2=[GSHARP-BUFFER:LYRICS-STAFF :name "lyrics" ] #3=[GSHARP-BUFFER:FIVELINE-STAFF :name "lower" :clef [GSHARP-BUFFER:CLEF :name :BASS :lineno 6 ] :keysig [GSHARP-BUFFER:KEY-SIGNATURE :xoffset 0 :staff #3# :alterations #(:NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL :NATURAL) ] ]) :segments ([GSHARP-BUFFER:SEGMENT :layers ([GSHARP-BUFFER:LYRICS-LAYER :name "lyrics" :staves (#2#) :head [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:LYRICS-BAR :elements COMMON-LISP:NIL ]) ] :body [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:LYRICS-BAR :elements ([GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #() ] [GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #(116 104 97 116) ]) ] [GSHARP-BUFFER:LYRICS-BAR :elements ([GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #(102 105) ] [GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #(106 105) ] [GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 0 :staff #2# :text #(104 111) ] [GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 0 :staff #2# :text #(108 105) ] [GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #(100 97 121) ]) ] [GSHARP-BUFFER:LYRICS-BAR :elements ([GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #(102 101 101) ] [GSHARP-BUFFER:LYRICS-ELEMENT :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :staff #2# :text #(108 105 110 103) ]) ]) ] :tail [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:LYRICS-BAR :elements COMMON-LISP:NIL ]) ] ] [GSHARP-BUFFER:MELODY-LAYER :name "bass" :staves (#3#) :head [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:MELODY-BAR :elements COMMON-LISP:NIL ]) ] :body [GSHARP-BUFFER:SLICE :bars ([GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes COMMON-LISP:NIL ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 1 :lbeams 0 :dots 0 :stem-direction :AUTO :notes COMMON-LISP:NIL ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 17 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 19 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 20 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 21 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 23 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 18 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 21 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 22 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 23 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 17 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 19 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 20 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 21 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 23 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 22 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 24 :staff #3# :head :FILLED :accidentals :SHARP :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 18 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ] [GSHARP-BUFFER:NOTE :pitch 22 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 19 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :FILLED :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 20 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ]) ] [GSHARP-BUFFER:MELODY-BAR :elements ([GSHARP-BUFFER:CLUSTER :xoffset 0 :notehead :HALF :rbeams 0 :lbeams 0 :dots 0 :stem-direction :AUTO :notes ([GSHARP-BUFFER:NOTE :pitch 17 :staff #3# :head :FILLED :accidentals :NATURAL :dots 0 ]) ] [GSHARP-BUFFER:CLUSTER [888 lines skipped] From rstrandh at common-lisp.net Wed Feb 15 17:46:53 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Wed, 15 Feb 2006 11:46:53 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060215174653.16E7F5D010@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv6974 Modified Files: gui.lisp Log Message: Gsharp now has an info pane (what Emacs calls a "mode-line"). --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/15 03:18:03 1.55 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/15 17:46:52 1.56 @@ -26,6 +26,38 @@ (defclass gsharp-pane (score-pane:score-pane) ((view :initarg :view :accessor view))) +(defvar *info-bg-color* +gray85+) +(defvar *info-fg-color* +black+) + +(defclass gsharp-info-pane (info-pane) + () + (:default-initargs + :height 20 :max-height 20 :min-height 20 + :display-function 'display-info + :incremental-redisplay t)) + +(defun display-info (frame pane) + (declare (ignore frame)) + (let* ((master-pane (master-pane pane)) + (view (view master-pane)) + (buffer (buffer view))) + (princ " " pane) + (princ (cond ((and (needs-saving buffer) + (read-only-p buffer) + "%*")) + ((needs-saving buffer) "**") + ((read-only-p buffer) "%%") + (t "--")) + pane) + (princ " " pane) + (with-text-face (pane :bold) + (format pane "~25A" (name buffer))) + (with-text-family (pane :sans-serif) + (princ (if (recordingp *application-frame*) + "Def" + "") + pane)))) + (define-application-frame gsharp (standard-application-frame esa-frame-mixin) ((views :initarg :views :initform '() :accessor views) @@ -33,16 +65,24 @@ (:menu-bar menubar-command-table :height 25) (:pointer-documentation t) (:panes - (score (let ((win (make-pane 'gsharp-pane - :width 400 :height 500 - :name "score" - ;; :incremental-redisplay t - :double-buffering t - :display-function 'display-score - :command-table 'total-melody-table))) + (score (let* ((win (make-pane 'gsharp-pane + :width 400 :height 500 + :name "score" + ;; :incremental-redisplay t + :double-buffering t + :display-function 'display-score + :command-table 'total-melody-table)) + (info (make-pane 'gsharp-info-pane + :master-pane win + :background *info-bg-color* + :foreground *info-fg-color*))) (setf (windows *application-frame*) (list win)) (setf (view win) (car (views *application-frame*))) - win)) + (vertically () + (scrolling (:width 750 :height 500 + :min-height 400 :max-height 20000) + win) + info))) (state (make-pane 'score-pane:score-pane :width 50 :height 200 :name "state" @@ -57,9 +97,7 @@ (default (vertically () (horizontally () - (scrolling (:width 750 :height 500 - :min-height 400 :max-height 20000) - score) + score (vertically () (scrolling (:width 80 :height 200) state) (scrolling (:width 80 :height 300 From rstrandh at common-lisp.net Mon Feb 20 20:19:37 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 20 Feb 2006 14:19:37 -0600 (CST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060220201937.533F12A024@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory common-lisp:/tmp/cvs-serv4071 Modified Files: modes.lisp Log Message: Introduced a new command table `rhythmic-table' that contains commands that are common for all rhythmic elements. `cluster-table' and `lyrics-table' now inherit from `rhythmic-table'. Moved some key bindings around to more appropriate command tables. --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/15 03:18:03 1.10 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/20 20:19:37 1.11 @@ -7,12 +7,12 @@ (set-key `(com-backward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\b :control))) (set-key `(com-delete-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\d :control))) (set-key 'com-insert-measure-bar 'global-gsharp-table '(#\|)) -(set-key 'com-more-dots 'global-gsharp-table '((#\.))) -(set-key 'com-more-lbeams 'global-gsharp-table '((#\[))) -(set-key 'com-more-rbeams 'global-gsharp-table '((#\]))) +(set-key 'com-erase-element 'global-gsharp-table '((#\h :control))) + +;;; FIXME where are the corresponding commands? (set-key 'com-left 'global-gsharp-table '((#\l :meta))) (set-key 'com-right 'global-gsharp-table '((#\r :meta))) -(set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control))) + (set-key 'com-istate-more-dots 'global-gsharp-table '((#\i) (#\.))) (set-key 'com-istate-more-lbeams 'global-gsharp-table '((#\i) (#\[))) (set-key 'com-istate-more-rbeams 'global-gsharp-table '((#\i) (#\]))) @@ -38,22 +38,28 @@ (set-key 'com-insert-note-g 'melody-table '(#\g)) (set-key 'com-insert-rest 'melody-table '((#\,))) (set-key 'com-insert-empty-cluster 'melody-table '((#\Space))) -(set-key 'com-current-increment 'melody-table '((#\p))) -(set-key 'com-current-decrement 'melody-table '((#\n))) -(set-key 'com-fewer-dots 'melody-table '((#\x) (#\.))) -(set-key 'com-fewer-lbeams 'melody-table '((#\x) (#\[))) -(set-key 'com-fewer-rbeams 'melody-table '((#\x) (#\]))) -(set-key 'com-erase-element 'melody-table '((#\h :control))) -(set-key 'com-rotate-notehead 'melody-table '((#\h :meta))) -(set-key 'com-rotate-stem-direction 'melody-table '((#\s :meta))) (set-key 'com-more-sharps 'melody-table '((#\# :meta))) (set-key 'com-more-sharps 'melody-table '((#\# :meta :shift))) (set-key 'com-more-flats 'melody-table '((#\@ :meta :shift))) +;;; the rhythmic table contains command that are specific +;;; to rhythmic elements +(define-command-table rhythmic-table) + +(set-key 'com-more-dots 'rhythmic-table '((#\.))) +(set-key 'com-more-lbeams 'rhythmic-table '((#\[))) +(set-key 'com-more-rbeams 'rhythmic-table '((#\]))) +(set-key 'com-fewer-dots 'rhythmic-table '((#\x) (#\.))) +(set-key 'com-fewer-lbeams 'rhythmic-table '((#\x) (#\[))) +(set-key 'com-fewer-rbeams 'rhythmic-table '((#\x) (#\]))) +(set-key 'com-rotate-notehead 'rhythmic-table '((#\h :meta))) +(set-key 'com-rotate-notehead 'rhythmic-table '((#\r :control))) ; why this one too? + ;;; the cluster table contains commands that are specific to ;;; clusters -(define-command-table cluster-table) +(define-command-table cluster-table + :inherit-from (rhythmic-table)) (set-key 'com-sharper 'cluster-table '((#\#))) (set-key 'com-flatter 'cluster-table '(#\@)) @@ -70,10 +76,14 @@ (set-key 'com-tie-note-right 'cluster-table '((#\}))) (set-key 'com-untie-note-left 'cluster-table '((#\x) (#\{))) (set-key 'com-untie-note-right 'cluster-table '((#\x) (#\}))) +(set-key 'com-rotate-stem-direction 'cluster-table '((#\s :meta))) +(set-key 'com-current-increment 'cluster-table '((#\p))) +(set-key 'com-current-decrement 'cluster-table '((#\n))) ;;; lyrics mode table -(define-command-table lyrics-table) +(define-command-table lyrics-table + :inherit-from (rhythmic-table)) (set-key (lambda () (erase-char (cur-element))) 'lyrics-table '((#\h :control))) (set-key 'com-erase-element 'lyrics-table '((#\h :meta))) From rstrandh at common-lisp.net Sun Feb 26 22:14:30 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Sun, 26 Feb 2006 17:14:30 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Fonts Message-ID: <20060226221430.710767C00C@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Fonts In directory clnet:/tmp/cvs-serv9721 Modified Files: charmap.mf ties.mf Log Message: Cleaned up the ties. --- /project/gsharp/cvsroot/gsharp/Fonts/charmap.mf 2004/03/26 14:25:34 1.4 +++ /project/gsharp/cvsroot/gsharp/Fonts/charmap.mf 2006/02/26 22:14:30 1.5 @@ -120,103 +120,53 @@ global_variable(numeric)(small_tie_eight_down)(160) global_variable(numeric)(small_tie_eight_down_light)(161) -global_variable(numeric)(large_tie_line_one_up)(162) -global_variable(numeric)(large_tie_line_one_up_light)(163) -global_variable(numeric)(large_tie_line_two_up)(164) -global_variable(numeric)(large_tie_line_two_up_light)(165) -global_variable(numeric)(large_tie_line_three_up)(166) -global_variable(numeric)(large_tie_line_three_up_light)(167) -global_variable(numeric)(large_tie_line_four_up)(168) -global_variable(numeric)(large_tie_line_four_up_light)(169) -global_variable(numeric)(large_tie_line_five_up)(170) -global_variable(numeric)(large_tie_line_five_up_light)(171) -global_variable(numeric)(large_tie_line_six_up)(172) -global_variable(numeric)(large_tie_line_six_up_light)(173) -global_variable(numeric)(large_tie_line_seven_up)(174) -global_variable(numeric)(large_tie_line_seven_up_light)(175) -global_variable(numeric)(large_tie_line_eight_up)(176) -global_variable(numeric)(large_tie_line_eight_up_light)(177) -global_variable(numeric)(large_tie_line_nine_up)(178) -global_variable(numeric)(large_tie_line_nine_up_light)(179) -global_variable(numeric)(large_tie_line_ten_up)(180) -global_variable(numeric)(large_tie_line_ten_up_light)(181) -global_variable(numeric)(large_tie_line_left_up)(182) -global_variable(numeric)(large_tie_line_left_up_light)(183) -global_variable(numeric)(large_tie_line_right_up)(184) -global_variable(numeric)(large_tie_line_right_up_light)(185) +global_variable(numeric)(large_tie_one_up)(162) +global_variable(numeric)(large_tie_one_up_light)(163) +global_variable(numeric)(large_tie_two_up)(164) +global_variable(numeric)(large_tie_two_up_light)(165) +global_variable(numeric)(large_tie_three_up)(166) +global_variable(numeric)(large_tie_three_up_light)(167) +global_variable(numeric)(large_tie_four_up)(168) +global_variable(numeric)(large_tie_four_up_light)(169) +global_variable(numeric)(large_tie_five_up)(170) +global_variable(numeric)(large_tie_five_up_light)(171) +global_variable(numeric)(large_tie_six_up)(172) +global_variable(numeric)(large_tie_six_up_light)(173) +global_variable(numeric)(large_tie_seven_up)(174) +global_variable(numeric)(large_tie_seven_up_light)(175) +global_variable(numeric)(large_tie_eight_up)(176) +global_variable(numeric)(large_tie_eight_up_light)(177) +global_variable(numeric)(large_tie_nine_up)(178) +global_variable(numeric)(large_tie_nine_up_light)(179) +global_variable(numeric)(large_tie_ten_up)(180) +global_variable(numeric)(large_tie_ten_up_light)(181) +global_variable(numeric)(large_tie_left_up)(182) +global_variable(numeric)(large_tie_left_up_light)(183) +global_variable(numeric)(large_tie_right_up)(184) +global_variable(numeric)(large_tie_right_up_light)(185) -global_variable(numeric)(large_tie_space_one_up)(186) -global_variable(numeric)(large_tie_space_one_up_light)(187) -global_variable(numeric)(large_tie_space_two_up)(188) -global_variable(numeric)(large_tie_space_two_up_light)(189) -global_variable(numeric)(large_tie_space_three_up)(190) -global_variable(numeric)(large_tie_space_three_up_light)(191) -global_variable(numeric)(large_tie_space_four_up)(192) -global_variable(numeric)(large_tie_space_four_up_light)(193) -global_variable(numeric)(large_tie_space_five_up)(194) -global_variable(numeric)(large_tie_space_five_up_light)(195) -global_variable(numeric)(large_tie_space_six_up)(196) -global_variable(numeric)(large_tie_space_six_up_light)(197) -global_variable(numeric)(large_tie_space_seven_up)(198) -global_variable(numeric)(large_tie_space_seven_up_light)(199) -global_variable(numeric)(large_tie_space_eight_up)(200) -global_variable(numeric)(large_tie_space_eight_up_light)(201) -global_variable(numeric)(large_tie_space_nine_up)(202) -global_variable(numeric)(large_tie_space_nine_up_light)(203) -global_variable(numeric)(large_tie_space_ten_up)(204) -global_variable(numeric)(large_tie_space_ten_up_light)(205) -global_variable(numeric)(large_tie_space_left_up)(206) -global_variable(numeric)(large_tie_space_left_up_light)(207) -global_variable(numeric)(large_tie_space_right_up)(208) -global_variable(numeric)(large_tie_space_right_up_light)(209) - -global_variable(numeric)(large_tie_line_one_down)(210) -global_variable(numeric)(large_tie_line_one_down_light)(211) -global_variable(numeric)(large_tie_line_two_down)(212) -global_variable(numeric)(large_tie_line_two_down_light)(213) -global_variable(numeric)(large_tie_line_three_down)(214) -global_variable(numeric)(large_tie_line_three_down_light)(215) -global_variable(numeric)(large_tie_line_four_down)(216) -global_variable(numeric)(large_tie_line_four_down_light)(217) -global_variable(numeric)(large_tie_line_five_down)(218) -global_variable(numeric)(large_tie_line_five_down_light)(219) -global_variable(numeric)(large_tie_line_six_down)(220) -global_variable(numeric)(large_tie_line_six_down_light)(221) -global_variable(numeric)(large_tie_line_seven_down)(222) -global_variable(numeric)(large_tie_line_seven_down_light)(223) -global_variable(numeric)(large_tie_line_eight_down)(224) -global_variable(numeric)(large_tie_line_eight_down_light)(225) -global_variable(numeric)(large_tie_line_nine_down)(226) -global_variable(numeric)(large_tie_line_nine_down_light)(227) -global_variable(numeric)(large_tie_line_ten_down)(228) -global_variable(numeric)(large_tie_line_ten_down_light)(229) -global_variable(numeric)(large_tie_line_left_down)(230) -global_variable(numeric)(large_tie_line_left_down_light)(231) -global_variable(numeric)(large_tie_line_right_down)(232) -global_variable(numeric)(large_tie_line_right_down_light)(233) - -global_variable(numeric)(large_tie_space_one_down)(234) -global_variable(numeric)(large_tie_space_one_down_light)(235) -global_variable(numeric)(large_tie_space_two_down)(236) -global_variable(numeric)(large_tie_space_two_down_light)(237) -global_variable(numeric)(large_tie_space_three_down)(238) -global_variable(numeric)(large_tie_space_three_down_light)(239) -global_variable(numeric)(large_tie_space_four_down)(240) -global_variable(numeric)(large_tie_space_four_down_light)(241) -global_variable(numeric)(large_tie_space_five_down)(242) -global_variable(numeric)(large_tie_space_five_down_light)(243) -global_variable(numeric)(large_tie_space_six_down)(244) -global_variable(numeric)(large_tie_space_six_down_light)(245) -global_variable(numeric)(large_tie_space_seven_down)(246) -global_variable(numeric)(large_tie_space_seven_down_light)(247) -global_variable(numeric)(large_tie_space_eight_down)(248) -global_variable(numeric)(large_tie_space_eight_down_light)(249) -global_variable(numeric)(large_tie_space_nine_down)(250) -global_variable(numeric)(large_tie_space_nine_down_light)(251) -global_variable(numeric)(large_tie_space_ten_down)(252) -global_variable(numeric)(large_tie_space_ten_down_light)(253) -global_variable(numeric)(large_tie_space_left_down)(254) -global_variable(numeric)(large_tie_space_left_down_light)(255) -global_variable(numeric)(large_tie_space_right_down)(256) -global_variable(numeric)(large_tie_space_right_down_light)(257) +global_variable(numeric)(large_tie_one_down)(186) +global_variable(numeric)(large_tie_one_down_light)(187) +global_variable(numeric)(large_tie_two_down)(188) +global_variable(numeric)(large_tie_two_down_light)(189) +global_variable(numeric)(large_tie_three_down)(190) +global_variable(numeric)(large_tie_three_down_light)(191) +global_variable(numeric)(large_tie_four_down)(192) +global_variable(numeric)(large_tie_four_down_light)(193) +global_variable(numeric)(large_tie_five_down)(194) +global_variable(numeric)(large_tie_five_down_light)(195) +global_variable(numeric)(large_tie_six_down)(196) +global_variable(numeric)(large_tie_six_down_light)(197) +global_variable(numeric)(large_tie_seven_down)(198) +global_variable(numeric)(large_tie_seven_down_light)(199) +global_variable(numeric)(large_tie_eight_down)(200) +global_variable(numeric)(large_tie_eight_down_light)(201) +global_variable(numeric)(large_tie_nine_down)(202) +global_variable(numeric)(large_tie_nine_down_light)(203) +global_variable(numeric)(large_tie_ten_down)(204) +global_variable(numeric)(large_tie_ten_down_light)(205) +global_variable(numeric)(large_tie_left_down)(206) +global_variable(numeric)(large_tie_left_down_light)(207) +global_variable(numeric)(large_tie_right_down)(208) +global_variable(numeric)(large_tie_right_down_light)(209) --- /project/gsharp/cvsroot/gsharp/Fonts/ties.mf 2004/03/26 14:25:35 1.3 +++ /project/gsharp/cvsroot/gsharp/Fonts/ties.mf 2006/02/26 22:14:30 1.4 @@ -4,11 +4,15 @@ (round(0.33 * staff_line_distance)); local_variable(numeric)(small_tie_height) (round(0.5 * staff_line_distance)); + local_variable(numeric)(large_tie_height) + (round(1.0 * staff_line_distance)); save small_tie_up; def small_tie_up(expr width) = local_variable(numeric)(top) - (round(0.33 * staff_line_distance)-1); + (round(0.5 * (staff_line_distance + + staff_line_thickness + + small_tie_height))); fill ((0, top){right} .. (width, top-small_tie_height) -- (width-1, top-small_tie_height) .. @@ -29,7 +33,9 @@ save small_tie_down; def small_tie_down(expr width) = local_variable(numeric)(bot) - (round(0.33 * staff_line_distance)); + (round(0.5 * (staff_line_distance - + staff_line_thickness + + small_tie_height))); fill ((0, -bot){right} .. (width, small_tie_height-bot) -- (width-1, small_tie_height-bot) .. @@ -175,127 +181,111 @@ small_tie_down_light(round(2.67 * staff_line_distance)); end_character; - local_variable(numeric)(large_tie_line_height) - (round(0.5 * staff_line_distance)); - - local_variable(numeric)(large_tie_space_height) - (round(0.5 * staff_line_distance)); - save large_tie_up; - def large_tie_up(expr width_multiplier, height) = + def large_tie_up(expr width_multiplier) = local_variable(numeric)(top) - (round(0.33 * staff_line_distance)-1); + (round(11.0/6.0 * staff_line_distance)); local_variable(numeric)(width) (round(width_multiplier * staff_line_distance)); fill ((0, top){right} .. - (width, top-height) -- - (width-1, top-height) .. + (width, top-large_tie_height) -- + (width-1, top-large_tie_height) .. (0.3*width, top-tie_thickness) .. (0, top-tie_thickness) .. (-0.3*width, top-tie_thickness) .. - (-(width-1), top-height) -- - (-width, top-height) .. cycle) + (-(width-1), top-large_tie_height) -- + (-width, top-large_tie_height) .. cycle) scaled magnification; enddef; save large_tie_up_light; - def large_tie_up_light(expr width, height) = - large_tie_up(width, height); - stripes(width, 2*height); - enddef; - - save large_tie_line_up; - def large_tie_line_up(expr width_multiplier) = - large_tie_up(width_multiplier, round(1.0 * staff_line_distance)); - enddef; - - save large_tie_line_up_light; - def large_tie_line_up_light(expr width_multiplier) = - large_tie_up_light(width_multiplier, round(1.0 * staff_line_distance)); + def large_tie_up_light(expr width) = + large_tie_up(width); + stripes(width, 2*large_tie_height); enddef; - begin_character(large_tie_line_one_up) - large_tie_line_up(2.0); + begin_character(large_tie_one_up) + large_tie_up(2.0); end_character; - begin_character(large_tie_line_one_up_light) - large_tie_line_up_light(2.0); + begin_character(large_tie_one_up_light) + large_tie_up_light(2.0); end_character; - begin_character(large_tie_line_two_up) - large_tie_line_up(2.33); + begin_character(large_tie_two_up) + large_tie_up(2.33); end_character; - begin_character(large_tie_line_two_up_light) - large_tie_line_up_light(2.33); + begin_character(large_tie_two_up_light) + large_tie_up_light(2.33); end_character; - begin_character(large_tie_line_three_up) - large_tie_line_up(2.67); + begin_character(large_tie_three_up) + large_tie_up(2.67); end_character; - begin_character(large_tie_line_three_up_light) - large_tie_line_up_light(2.67); + begin_character(large_tie_three_up_light) + large_tie_up_light(2.67); end_character; - begin_character(large_tie_line_four_up) - large_tie_line_up(3.0); + begin_character(large_tie_four_up) + large_tie_up(3.0); end_character; - begin_character(large_tie_line_four_up_light) - large_tie_line_up_light(3.0); + begin_character(large_tie_four_up_light) + large_tie_up_light(3.0); end_character; - begin_character(large_tie_line_five_up) - large_tie_line_up(3.33); + begin_character(large_tie_five_up) + large_tie_up(3.33); end_character; - begin_character(large_tie_line_five_up_light) - large_tie_line_up_light(3.33); + begin_character(large_tie_five_up_light) + large_tie_up_light(3.33); end_character; - begin_character(large_tie_line_six_up) - large_tie_line_up(3.67); + begin_character(large_tie_six_up) + large_tie_up(3.67); end_character; - begin_character(large_tie_line_six_up_light) - large_tie_line_up_light(3.67); + begin_character(large_tie_six_up_light) + large_tie_up_light(3.67); end_character; - begin_character(large_tie_line_seven_up) - large_tie_line_up(4.0); + begin_character(large_tie_seven_up) + large_tie_up(4.0); end_character; - begin_character(large_tie_line_seven_up_light) - large_tie_line_up_light(4.0); + begin_character(large_tie_seven_up_light) + large_tie_up_light(4.0); end_character; - begin_character(large_tie_line_eight_up) - large_tie_line_up(4.33); + begin_character(large_tie_eight_up) + large_tie_up(4.33); end_character; - begin_character(large_tie_line_eight_up_light) - large_tie_line_up_light(4.33); + begin_character(large_tie_eight_up_light) + large_tie_up_light(4.33); end_character; - begin_character(large_tie_line_nine_up) - large_tie_line_up(4.67); + begin_character(large_tie_nine_up) + large_tie_up(4.67); end_character; - begin_character(large_tie_line_nine_up_light) - large_tie_line_up_light(4.67); + begin_character(large_tie_nine_up_light) + large_tie_up_light(4.67); end_character; - begin_character(large_tie_line_ten_up) - large_tie_line_up(5.0); + begin_character(large_tie_ten_up) + large_tie_up(5.0); end_character; - begin_character(large_tie_line_ten_up_light) - large_tie_line_up_light(5.0); + begin_character(large_tie_ten_up_light) + large_tie_up_light(5.0); end_character; - begin_character(large_tie_line_left_up) - large_tie_line_up(5.0); + begin_character(large_tie_left_up) + large_tie_up(5.0); erase fill ((0, -2 * staff_line_distance) -- (6 * staff_line_distance, -2 * staff_line_distance) -- (6 * staff_line_distance, 2 * staff_line_distance) -- @@ -303,8 +293,8 @@ scaled magnification; end_character; - begin_character(large_tie_line_left_up_light) - large_tie_line_up(5.0); + begin_character(large_tie_left_up_light) + large_tie_up(5.0); erase fill ((0, -2 * staff_line_distance) -- (6 * staff_line_distance, -2 * staff_line_distance) -- (6 * staff_line_distance, 2 * staff_line_distance) -- @@ -313,8 +303,8 @@ stripes(6 * staff_line_distance, 2 * staff_line_distance); end_character; - begin_character(large_tie_line_right_up) - large_tie_line_up(5.0); + begin_character(large_tie_right_up) + large_tie_up(5.0); erase fill ((0, -2 * staff_line_distance) -- (-6 * staff_line_distance, -2 * staff_line_distance) -- (-6 * staff_line_distance, 2 * staff_line_distance) -- @@ -322,8 +312,8 @@ scaled magnification; end_character; - begin_character(large_tie_line_right_up_light) - large_tie_line_up(5.0); + begin_character(large_tie_right_up_light) + large_tie_up(5.0); erase fill ((0, -2 * staff_line_distance) -- (-6 * staff_line_distance, -2 * staff_line_distance) -- (-6 * staff_line_distance, 2 * staff_line_distance) -- @@ -332,377 +322,112 @@ stripes(6 * staff_line_distance, 2 * staff_line_distance); end_character; - save large_tie_space_up; - def large_tie_space_up(expr width_multiplier) = - large_tie_up(width_multiplier, round(1.33 * staff_line_distance)); - enddef; - - save large_tie_space_up_light; - def large_tie_space_up_light(expr width_multiplier) = - large_tie_up_light(width_multiplier, round(1.33 * staff_line_distance)); - enddef; - - begin_character(large_tie_space_one_up) - large_tie_space_up(2.0); - end_character; - - begin_character(large_tie_space_one_up_light) - large_tie_space_up_light(2.0); - end_character; - - begin_character(large_tie_space_two_up) - large_tie_space_up(2.33); - end_character; - - begin_character(large_tie_space_two_up_light) - large_tie_space_up_light(2.33); - end_character; - - begin_character(large_tie_space_three_up) - large_tie_space_up(2.67); - end_character; - - begin_character(large_tie_space_three_up_light) - large_tie_space_up_light(2.67); - end_character; - - begin_character(large_tie_space_four_up) - large_tie_space_up(3.0); - end_character; - - begin_character(large_tie_space_four_up_light) - large_tie_space_up_light(3.0); - end_character; - - begin_character(large_tie_space_five_up) - large_tie_space_up(3.33); - end_character; - - begin_character(large_tie_space_five_up_light) - large_tie_space_up_light(3.33); - end_character; - - begin_character(large_tie_space_six_up) - large_tie_space_up(3.67); - end_character; - - begin_character(large_tie_space_six_up_light) - large_tie_space_up_light(3.67); - end_character; - - begin_character(large_tie_space_seven_up) - large_tie_space_up(4.0); - end_character; - - begin_character(large_tie_space_seven_up_light) - large_tie_space_up_light(4.0); - end_character; - - begin_character(large_tie_space_eight_up) - large_tie_space_up(4.33); - end_character; - - begin_character(large_tie_space_eight_up_light) - large_tie_space_up_light(4.33); - end_character; - - begin_character(large_tie_space_nine_up) - large_tie_space_up(4.67); - end_character; - - begin_character(large_tie_space_nine_up_light) - large_tie_space_up_light(4.67); - end_character; - - begin_character(large_tie_space_ten_up) - large_tie_space_up(5.0); - end_character; - - begin_character(large_tie_space_ten_up_light) - large_tie_space_up_light(5.0); - end_character; - - begin_character(large_tie_space_left_up) - large_tie_space_up(5.0); - erase fill ((0, -2 * staff_line_distance) -- - (6 * staff_line_distance, -2 * staff_line_distance) -- - (6 * staff_line_distance, 2 * staff_line_distance) -- - (0, 2 * staff_line_distance) -- cycle) - scaled magnification; - end_character; - - begin_character(large_tie_space_left_up_light) - large_tie_space_up(5.0); - erase fill ((0, -2 * staff_line_distance) -- - (6 * staff_line_distance, -2 * staff_line_distance) -- - (6 * staff_line_distance, 2 * staff_line_distance) -- - (0, 2 * staff_line_distance) -- cycle) - scaled magnification; - stripes(6 * staff_line_distance, 2 * staff_line_distance); - end_character; - - begin_character(large_tie_space_right_up) - large_tie_space_up(5.0); - erase fill ((0, -2 * staff_line_distance) -- - (-6 * staff_line_distance, -2 * staff_line_distance) -- - (-6 * staff_line_distance, 2 * staff_line_distance) -- - (0, 2 * staff_line_distance) -- cycle) - scaled magnification; - end_character; - - begin_character(large_tie_space_right_up_light) - large_tie_space_up(5.0); - erase fill ((0, -2 * staff_line_distance) -- - (-6 * staff_line_distance, -2 * staff_line_distance) -- - (-6 * staff_line_distance, 2 * staff_line_distance) -- - (0, 2 * staff_line_distance) -- cycle) - scaled magnification; - stripes(6 * staff_line_distance, 2 * staff_line_distance); - end_character; save large_tie_down; - def large_tie_down(expr width_multiplier, height) = + def large_tie_down(expr width_multiplier) = local_variable(numeric)(bot) - (round(0.33 * staff_line_distance)); + (round(11.0/6.0 * staff_line_distance) - staff_line_thickness); local_variable(numeric)(width) (round(width_multiplier * staff_line_distance)); fill ((0, -bot){right} .. - (width, height-bot) -- - (width-1, height-bot) .. + (width, large_tie_height-bot) -- + (width-1, large_tie_height-bot) .. (0.3*width, tie_thickness-bot) .. (0, tie_thickness-bot) .. (-0.3*width, tie_thickness-bot) .. - (-(width-1), height-bot) -- - (-width, height-bot) .. cycle) + (-(width-1), large_tie_height-bot) -- + (-width, large_tie_height-bot) .. cycle) scaled magnification; enddef; save large_tie_down_light; - def large_tie_down_light(expr width, height) = - large_tie_down(width, height); [310 lines skipped] From rstrandh at common-lisp.net Sun Feb 26 22:18:40 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Sun, 26 Feb 2006 17:18:40 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060226221840.0F9D247027@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv11186 Modified Files: packages.lisp drawing.lisp charmap.lisp score-pane.lisp Log Message: The code for drawing ties is basically done (score-pane.lisp). The code in drawing.lisp that actually decides how to call the tie-drawing functions is only rudimentary (only upward ties are drawn at the moment). --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/15 02:54:27 1.45 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/26 22:18:39 1.46 @@ -61,7 +61,87 @@ #:+glyph-flags-down-one+ #:+glyph-flags-down-two+ #:+glyph-flags-down-three+ #:+glyph-flags-down-four+ #:+glyph-flags-down-five+ #:+glyph-flags-up-one+ #:+glyph-flags-up-two+ #:+glyph-flags-up-three+ #:+glyph-flags-up-four+ - #:+glyph-flags-up-five+)) + #:+glyph-flags-up-five+ + #:+glyph-small-tie-one-up+ + #:+glyph-small-tie-one-up-light+ + #:+glyph-small-tie-two-up+ + #:+glyph-small-tie-two-up-light+ + #:+glyph-small-tie-three-up+ + #:+glyph-small-tie-three-up-light+ + #:+glyph-small-tie-four-up+ + #:+glyph-small-tie-four-up-light+ + #:+glyph-small-tie-five-up+ + #:+glyph-small-tie-five-up-light+ + #:+glyph-small-tie-six-up+ + #:+glyph-small-tie-six-up-light+ + #:+glyph-small-tie-seven-up+ + #:+glyph-small-tie-seven-up-light+ + #:+glyph-small-tie-eight-up+ + #:+glyph-small-tie-eight-up-light+ + #:+glyph-small-tie-one-down+ + #:+glyph-small-tie-one-down-light+ + #:+glyph-small-tie-two-down+ + #:+glyph-small-tie-two-down-light+ + #:+glyph-small-tie-three-down+ + #:+glyph-small-tie-three-down-light+ + #:+glyph-small-tie-four-down+ + #:+glyph-small-tie-four-down-light+ + #:+glyph-small-tie-five-down+ + #:+glyph-small-tie-five-down-light+ + #:+glyph-small-tie-six-down+ + #:+glyph-small-tie-six-down-light+ + #:+glyph-small-tie-seven-down+ + #:+glyph-small-tie-seven-down-light+ + #:+glyph-small-tie-eight-down+ + #:+glyph-small-tie-eight-down-light+ + #:+glyph-large-tie-one-up+ + #:+glyph-large-tie-one-up-light+ + #:+glyph-large-tie-two-up+ + #:+glyph-large-tie-two-up-light+ + #:+glyph-large-tie-three-up+ + #:+glyph-large-tie-three-up-light+ + #:+glyph-large-tie-four-up+ + #:+glyph-large-tie-four-up-light+ + #:+glyph-large-tie-five-up+ + #:+glyph-large-tie-five-up-light+ + #:+glyph-large-tie-six-up+ + #:+glyph-large-tie-six-up-light+ + #:+glyph-large-tie-seven-up+ + #:+glyph-large-tie-seven-up-light+ + #:+glyph-large-tie-eight-up+ + #:+glyph-large-tie-eight-up-light+ + #:+glyph-large-tie-nine-up+ + #:+glyph-large-tie-nine-up-light+ + #:+glyph-large-tie-ten-up+ + #:+glyph-large-tie-ten-up-light+ + #:+glyph-large-tie-left-up+ + #:+glyph-large-tie-left-up-light+ + #:+glyph-large-tie-right-up+ + #:+glyph-large-tie-right-up-light+ + #:+glyph-large-tie-one-down+ + #:+glyph-large-tie-one-down-light+ + #:+glyph-large-tie-two-down+ + #:+glyph-large-tie-two-down-light+ + #:+glyph-large-tie-three-down+ + #:+glyph-large-tie-three-down-light+ + #:+glyph-large-tie-four-down+ + #:+glyph-large-tie-four-down-light+ + #:+glyph-large-tie-five-down+ + #:+glyph-large-tie-five-down-light+ + #:+glyph-large-tie-six-down+ + #:+glyph-large-tie-six-down-light+ + #:+glyph-large-tie-seven-down+ + #:+glyph-large-tie-seven-down-light+ + #:+glyph-large-tie-eight-down+ + #:+glyph-large-tie-eight-down-light+ + #:+glyph-large-tie-nine-down+ + #:+glyph-large-tie-nine-down-light+ + #:+glyph-large-tie-ten-down+ + #:+glyph-large-tie-ten-down-light+ + #:+glyph-large-tie-left-down+ + #:+glyph-large-tie-left-down-light+ + #:+glyph-large-tie-right-down+ + #:+glyph-large-tie-right-down-light+)) (defpackage :score-pane (:use :clim :clim-extensions :clim-lisp :sdl :esa) @@ -71,7 +151,7 @@ #: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 - #:draw-tie + #:draw-tie-up #:draw-tie-down #:with-score-pane #:with-vertical-score-position #:with-staff-size #:with-notehead-right-offsets #:with-suspended-note-offset --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/14 03:00:52 1.62 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/02/26 22:18:39 1.63 @@ -340,11 +340,11 @@ (= (pitch n1) (pitch n2)) (eq (staff n1) (staff n2)) (accidentals n1) (accidentals n2)) - (let ((x1 (final-absolute-note-xoffset n1)) - (x2 (final-absolute-note-xoffset n2)) - (y (- (score-pane:staff-step (note-position n1))))) + (let ((x1 (+ (final-absolute-note-xoffset n1) (score-pane:staff-step 1.5))) + (x2 (- (final-absolute-note-xoffset n2) (score-pane:staff-step 1.5))) + (pos (note-position n1))) (score-pane:with-vertical-score-position (pane (staff-yoffset (staff n1))) - (score-pane:draw-tie pane x1 x2 y))))))))))) + (score-pane:draw-tie-up pane x1 x2 (if (oddp pos) (1+ pos) pos)))))))))))) (defun draw-system (pane measures) (loop for measure in measures do --- /project/gsharp/cvsroot/gsharp/charmap.lisp 2004/02/16 15:46:10 1.1.1.1 +++ /project/gsharp/cvsroot/gsharp/charmap.lisp 2006/02/26 22:18:39 1.2 @@ -87,3 +87,88 @@ (defconstant +glyph-flags-up-four-light+ 127) (defconstant +glyph-flags-up-five+ 128) (defconstant +glyph-flags-up-five-light+ 129) + +(defconstant +glyph-small-tie-one-up+ 130) +(defconstant +glyph-small-tie-one-up-light+ 131) +(defconstant +glyph-small-tie-two-up+ 132) +(defconstant +glyph-small-tie-two-up-light+ 133) +(defconstant +glyph-small-tie-three-up+ 134) +(defconstant +glyph-small-tie-three-up-light+ 135) +(defconstant +glyph-small-tie-four-up+ 136) +(defconstant +glyph-small-tie-four-up-light+ 137) +(defconstant +glyph-small-tie-five-up+ 138) +(defconstant +glyph-small-tie-five-up-light+ 139) +(defconstant +glyph-small-tie-six-up+ 140) +(defconstant +glyph-small-tie-six-up-light+ 141) +(defconstant +glyph-small-tie-seven-up+ 142) +(defconstant +glyph-small-tie-seven-up-light+ 143) +(defconstant +glyph-small-tie-eight-up+ 144) +(defconstant +glyph-small-tie-eight-up-light+ 145) + +(defconstant +glyph-small-tie-one-down+ 146) +(defconstant +glyph-small-tie-one-down-light+ 147) +(defconstant +glyph-small-tie-two-down+ 148) +(defconstant +glyph-small-tie-two-down-light+ 149) +(defconstant +glyph-small-tie-three-down+ 150) +(defconstant +glyph-small-tie-three-down-light+ 151) +(defconstant +glyph-small-tie-four-down+ 152) +(defconstant +glyph-small-tie-four-down-light+ 153) +(defconstant +glyph-small-tie-five-down+ 154) +(defconstant +glyph-small-tie-five-down-light+ 155) +(defconstant +glyph-small-tie-six-down+ 156) +(defconstant +glyph-small-tie-six-down-light+ 157) +(defconstant +glyph-small-tie-seven-down+ 158) +(defconstant +glyph-small-tie-seven-down-light+ 159) +(defconstant +glyph-small-tie-eight-down+ 160) +(defconstant +glyph-small-tie-eight-down-light+ 161) + +(defconstant +glyph-large-tie-one-up+ 162) +(defconstant +glyph-large-tie-one-up-light+ 163) +(defconstant +glyph-large-tie-two-up+ 164) +(defconstant +glyph-large-tie-two-up-light+ 165) +(defconstant +glyph-large-tie-three-up+ 166) +(defconstant +glyph-large-tie-three-up-light+ 167) +(defconstant +glyph-large-tie-four-up+ 168) +(defconstant +glyph-large-tie-four-up-light+ 169) +(defconstant +glyph-large-tie-five-up+ 170) +(defconstant +glyph-large-tie-five-up-light+ 171) +(defconstant +glyph-large-tie-six-up+ 172) +(defconstant +glyph-large-tie-six-up-light+ 173) +(defconstant +glyph-large-tie-seven-up+ 174) +(defconstant +glyph-large-tie-seven-up-light+ 175) +(defconstant +glyph-large-tie-eight-up+ 176) +(defconstant +glyph-large-tie-eight-up-light+ 177) +(defconstant +glyph-large-tie-nine-up+ 178) +(defconstant +glyph-large-tie-nine-up-light+ 179) +(defconstant +glyph-large-tie-ten-up+ 180) +(defconstant +glyph-large-tie-ten-up-light+ 181) +(defconstant +glyph-large-tie-left-up+ 182) +(defconstant +glyph-large-tie-left-up-light+ 183) +(defconstant +glyph-large-tie-right-up+ 184) +(defconstant +glyph-large-tie-right-up-light+ 185) + +(defconstant +glyph-large-tie-one-down+ 186) +(defconstant +glyph-large-tie-one-down-light+ 187) +(defconstant +glyph-large-tie-two-down+ 188) +(defconstant +glyph-large-tie-two-down-light+ 189) +(defconstant +glyph-large-tie-three-down+ 190) +(defconstant +glyph-large-tie-three-down-light+ 191) +(defconstant +glyph-large-tie-four-down+ 192) +(defconstant +glyph-large-tie-four-down-light+ 193) +(defconstant +glyph-large-tie-five-down+ 194) +(defconstant +glyph-large-tie-five-down-light+ 195) +(defconstant +glyph-large-tie-six-down+ 196) +(defconstant +glyph-large-tie-six-down-light+ 197) +(defconstant +glyph-large-tie-seven-down+ 198) +(defconstant +glyph-large-tie-seven-down-light+ 199) +(defconstant +glyph-large-tie-eight-down+ 200) +(defconstant +glyph-large-tie-eight-down-light+ 201) +(defconstant +glyph-large-tie-nine-down+ 202) +(defconstant +glyph-large-tie-nine-down-light+ 203) +(defconstant +glyph-large-tie-ten-down+ 204) +(defconstant +glyph-large-tie-ten-down-light+ 205) +(defconstant +glyph-large-tie-left-down+ 206) +(defconstant +glyph-large-tie-left-down-light+ 207) +(defconstant +glyph-large-tie-right-down+ 208) +(defconstant +glyph-large-tie-right-down-light+ 209) + --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/02/14 03:00:52 1.20 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/02/26 22:18:39 1.21 @@ -168,12 +168,10 @@ (defun draw-antialiased-glyph (pane glyph-no x staff-step) (let* ((extra (if *light-glyph* 1 0)) (matrix (glyph *font* (+ glyph-no extra))) - (pixmap (pane-pixmap pane matrix)) - (width (pixmap-width pixmap)) - (height (pixmap-height pixmap))) + (pixmap (pane-pixmap pane matrix))) (multiple-value-bind (dx dy) (glyph-offsets *font* (+ glyph-no extra)) (let ((x1 (+ x dx)) - (y1 (+ (staff-step staff-step) dy))) + (y1 (- dy (staff-step staff-step)))) (draw-pixmap* pane pixmap x1 y1))))) ;;; Given a pane, an x position (measured in pixels) a y position @@ -627,9 +625,65 @@ (draw-horizontal-beam pane xx1 y1 xx2) (draw-sloped-beam medium xx1 y1 xx2 y2)))))) -;;; FIXME obviously -(defun draw-tie (pane x1 x2 y) - (draw-rectangle* pane x1 (1- y) x2 (1+ y) :ink +blue+)) +(defun draw-tie-up (pane x1 x2 staff-step) + (let ((dist (/ (- x2 x1) (staff-step 4/3)))) + (if (> dist 19) + (let ((xx1 (round (+ x1 (staff-step 10)))) + (xx2 (round (- x2 (staff-step 10)))) + (y1 (- (round (staff-step (+ staff-step 11/3))))) + (thickness (round (staff-step 2/3)))) + (draw-antialiased-glyph pane +glyph-large-tie-left-up+ xx1 staff-step) + (draw-antialiased-glyph pane +glyph-large-tie-right-up+ xx2 staff-step) + (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness))) + (let ((glyph-no (cond ((> dist 18) +glyph-large-tie-ten-up+) + ((> dist 17) +glyph-large-tie-nine-up+) + ((> dist 16) +glyph-large-tie-eight-up+) + ((> dist 15) +glyph-large-tie-seven-up+) + ((> dist 14) +glyph-large-tie-six-up+) + ((> dist 13) +glyph-large-tie-five-up+) + ((> dist 12) +glyph-large-tie-four-up+) + ((> dist 11) +glyph-large-tie-three-up+) + ((> dist 10) +glyph-large-tie-two-up+) + ((> dist 9) +glyph-large-tie-one-up+) + ((> dist 8) +glyph-small-tie-eight-up+) + ((> dist 7) +glyph-small-tie-seven-up+) + ((> dist 6) +glyph-small-tie-six-up+) + ((> dist 5) +glyph-small-tie-five-up+) + ((> dist 4) +glyph-small-tie-four-up+) + ((> dist 3) +glyph-small-tie-three-up+) + ((> dist 2) +glyph-small-tie-two-up+) + (t +glyph-small-tie-one-up+)))) + (draw-antialiased-glyph pane glyph-no (round (* 0.5 (+ x1 x2))) staff-step))))) + +(defun draw-tie-down (pane x1 x2 staff-step) + (let ((dist (/ (- x2 x1) (staff-step 4/3)))) + (if (> dist 19) + (let ((xx1 (round (+ x1 (staff-step 10)))) + (xx2 (round (- x2 (staff-step 10)))) + (y1 (- (round (staff-step (+ staff-step 11/3))))) + (thickness (round (staff-step 2/3)))) + (draw-antialiased-glyph pane +glyph-large-tie-left-down+ xx1 staff-step) + (draw-antialiased-glyph pane +glyph-large-tie-right-down+ xx2 staff-step) + (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness))) + (let ((glyph-no (cond ((> dist 18) +glyph-large-tie-ten-down+) + ((> dist 17) +glyph-large-tie-nine-down+) + ((> dist 16) +glyph-large-tie-eight-down+) + ((> dist 15) +glyph-large-tie-seven-down+) + ((> dist 14) +glyph-large-tie-six-down+) + ((> dist 13) +glyph-large-tie-five-down+) + ((> dist 12) +glyph-large-tie-four-down+) + ((> dist 11) +glyph-large-tie-three-down+) + ((> dist 10) +glyph-large-tie-two-down+) + ((> dist 9) +glyph-large-tie-one-down+) + ((> dist 8) +glyph-small-tie-eight-down+) + ((> dist 7) +glyph-small-tie-seven-down+) + ((> dist 6) +glyph-small-tie-six-down+) + ((> dist 5) +glyph-small-tie-five-down+) + ((> dist 4) +glyph-small-tie-four-down+) + ((> dist 3) +glyph-small-tie-three-down+) + ((> dist 2) +glyph-small-tie-two-down+) + (t +glyph-small-tie-one-down+)))) + (draw-antialiased-glyph pane glyph-no (round (* 0.5 (+ x1 x2))) staff-step))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From rstrandh at common-lisp.net Tue Feb 28 23:42:12 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 28 Feb 2006 18:42:12 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060228234212.A17F67C00C@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv9336 Modified Files: buffer.lisp Log Message: Save ties when writing a buffer to disk. (thanks to Christophe Rhodes) --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/15 02:54:26 1.34 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/28 23:42:12 1.35 @@ -199,10 +199,11 @@ (apply #'make-instance 'note :pitch pitch :staff staff args)) (defmethod print-gsharp-object :after ((n note) stream) - (with-slots (pitch staff head accidentals dots) n + (with-slots (pitch staff head accidentals dots %tie-right %tie-left) n (format stream - "~_:pitch ~W ~_:staff ~W ~_:head ~W ~_:accidentals ~W ~_:dots ~W " - pitch staff head accidentals dots))) + "~_:pitch ~W ~_:staff ~W ~_:head ~W ~_:accidentals ~W ~_:dots ~W ~ + ~@[~_:tie-right ~W ~]~@[~_:tie-left ~W ~]" + pitch staff head accidentals dots %tie-right %tie-left))) (defun read-note-v3 (stream char n) (declare (ignore char n)) From rstrandh at common-lisp.net Tue Feb 28 23:49:18 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 28 Feb 2006 18:49:18 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20060228234918.609FA49056@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv10738 Modified Files: play.lisp Log Message: Improved midi-rendering of tied notes. (thanks to Christophe Rhodes) --- /project/gsharp/cvsroot/gsharp/play.lisp 2006/02/14 18:16:03 1.3 +++ /project/gsharp/cvsroot/gsharp/play.lisp 2006/02/28 23:49:18 1.4 @@ -24,13 +24,13 @@ :time time :status (+ #x90 channel) :key (midi-pitch note) :velocity 100)) - (notes element)) + (remove-if #'tie-left (notes element))) (mapcar (lambda (note) (make-instance 'note-off-message :time (+ time (* 128 (duration element))) :status (+ #x80 channel) :key (midi-pitch note) :velocity 100)) - (notes element))))) + (remove-if #'tie-right (notes element)))))) (defun events-from-bar (bar time channel) (mapcan (lambda (element)