January 2007 - gsharp-cvs@common-lisp.net

[gsharp-cvs] CVS gsharp
by crhodes 31 Jan '07

31 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv20391 Modified Files: gsharp.asd packages.lisp Removed Files: midi.lisp Log Message: Depend on external version of midi.lisp rather than bundling it. --- /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/11/16 12:58:23 1.14 +++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2007/01/31 15:25:04 1.15 @@ -20,7 +20,7 @@ :defaults *gsharp-directory*)) collect `(:file ,(pathname-name p) :pathname ,p)))))) -(gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain)) +(gsharp-defsystem (:gsharp :depends-on (:mcclim :flexichain :midi)) "packages" "utilities" "bezier" @@ -36,7 +36,6 @@ "drawing" "cursor" "input-state" - "midi" "modes" "play" "gui" --- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/06/21 16:31:54 1.58 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2007/01/31 15:25:04 1.59 @@ -168,21 +168,6 @@ (:shadowing-import-from :gsharp-buffer #:rest) (:export #:draw-buffer #:draw-the-cursor)) -(defpackage :midi - (:use :common-lisp) - (:export #:read-midi-file #:write-midi-file - #:midifile - #:midifile-format #:midifile-tracks #:midifile-division - #:message #:note-off-message #:note-on-message #:tempo-message - #:program-change-message - #:key-signature-message #:time-signature-message - #:smpte-offset-message - #:message-channel #:message-key #:message-time - #:message-velocity #:message-numerator #:message-denominator - #:message-sf #:message-mi #:message-tempo - #:header #:header-type - #:unknown-event #:status #:data-byte)) - (defpackage :gsharp-play (:use :common-lisp :midi :gsharp-buffer) (:shadowing-import-from :gsharp-buffer #:rest)

1 0

[gsharp-cvs] CVS gsharp
by crhodes 20 Jan '07

20 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv2908 Modified Files: INSTALL Log Message: New McCLIM release; no longer need ESA from climacs. --- /project/gsharp/cvsroot/gsharp/INSTALL 2006/06/05 01:23:15 1.5 +++ /project/gsharp/cvsroot/gsharp/INSTALL 2007/01/20 17:09:36 1.6 @@ -2,16 +2,15 @@ * A Common Lisp. Known to work: SBCL 0.9.12 -* McCLIM. The "Laetare Sunday" release is needed, along with +* McCLIM. The "Orthodox New Year" release is needed, along with ** spatial-trees; ** at least one means of displaying graphics: CLX is recommended, - but the OpenMCL/Cocoa bridge is a possibility. + but the OpenMCL/Cocoa bridge or the gtkairo backend are + possibilities. * Flexichain. ASDF-INSTALLable or from common-lisp.net CVS, the flexichain project, flexichain module. -* ESA. From common-lisp.net CVS, the climacs project, esa module. - Make sure ASDF knows how to find all of these projects. ;;; Start the lisp system

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 17 Jan '07

17 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv20348 Modified Files: buffer.lisp Log Message: Added a few comments --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/01/16 05:36:40 1.41 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/01/17 12:21:01 1.42 @@ -81,12 +81,17 @@ #'read-clef-v3 *gsharp-readtable-v3*) +;;; given a clef, return the staff step of the B that should have +;;; the first flat sign in key signatures with flats (defmethod b-position ((clef clef)) (ecase (name clef) (:bass (- (lineno clef) 4)) ((:treble :treble8) (+ (lineno clef) 2)) (:c (- (lineno clef) 1)))) + +;;; given a clef, return the staff step of the F that should have +;;; the first sharp sign in key signatures with sharps (defmethod f-position ((clef clef)) (ecase (name clef) (:bass (lineno clef))

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 16 Jan '07

16 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv22780 Modified Files: buffer.lisp Log Message: Turned print-gsharp-object into a generic function with (:method-combination :progn :most-specific-last), because that was how it was meant to work anyway. Turned #\] into a list-terminating character in the Gsharp readtables. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/01/16 05:21:39 1.40 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/01/16 05:36:40 1.41 @@ -3,19 +3,21 @@ (defparameter *gsharp-readtable-v3* (copy-readtable)) (defparameter *gsharp-readtable-v4* (copy-readtable)) -(make-dispatch-macro-character #\[ nil *gsharp-readtable-v3*) - (defun read-gsharp-object-v4 (stream char) (declare (ignore char)) (apply #'make-instance (read-delimited-list #\] stream t))) +(make-dispatch-macro-character #\[ nil *gsharp-readtable-v3*) (set-macro-character #\[ #'read-gsharp-object-v4 nil *gsharp-readtable-v4*) +(set-syntax-from-char #\] #\) *gsharp-readtable-v3*) +(set-syntax-from-char #\] #\) *gsharp-readtable-v4*) (defclass gsharp-object () ()) -(defgeneric print-gsharp-object (obj stream)) +(defgeneric print-gsharp-object (obj stream) + (:method-combination progn :most-specific-last)) -(defmethod print-gsharp-object ((obj gsharp-object) stream) +(defmethod print-gsharp-object progn ((obj gsharp-object) stream) (format stream "~s ~2i" (class-name (class-of obj)))) ;;; (defmethod print-object :around ((obj gsharp-object) stream) @@ -32,7 +34,7 @@ (defclass name-mixin () ((name :initarg :name :accessor name))) -(defmethod print-gsharp-object :after ((obj name-mixin) stream) +(defmethod print-gsharp-object progn ((obj name-mixin) stream) (format stream "~_:name ~W " (name obj))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -68,7 +70,7 @@ (:percussion 3)))) (make-instance 'clef :name name :lineno lineno)) -(defmethod print-gsharp-object :after ((c clef) stream) +(defmethod print-gsharp-object progn ((c clef) stream) (format stream "~_:lineno ~W " (lineno c))) (defun read-clef-v3 (stream char n) @@ -129,7 +131,7 @@ (declare (ignore name clef keysig)) (apply #'make-instance 'fiveline-staff args)) -(defmethod print-gsharp-object :after ((s fiveline-staff) stream) +(defmethod print-gsharp-object progn ((s fiveline-staff) stream) (format stream "~_:clef ~W ~_:keysig ~W " (clef s) (keysig s))) (defun read-fiveline-staff-v3 (stream char n) @@ -227,7 +229,7 @@ (ignore head accidentals dots)) (apply #'make-instance 'note :pitch pitch :staff staff args)) -(defmethod print-gsharp-object :after ((n note) stream) +(defmethod print-gsharp-object progn ((n note) stream) (with-slots (pitch staff head accidentals dots %tie-right %tie-left) n (format stream "~_:pitch ~W ~_:staff ~W ~_:head ~W ~_:accidentals ~W ~_:dots ~W ~ @@ -262,7 +264,7 @@ ((bar :initform nil :initarg :bar :accessor bar) (xoffset :initform 0 :initarg :xoffset :accessor xoffset))) -(defmethod print-gsharp-object :after ((e element) stream) +(defmethod print-gsharp-object progn ((e element) stream) (with-slots (notehead rbeams lbeams dots xoffset) e (format stream "~_:xoffset ~W " xoffset))) @@ -301,7 +303,7 @@ (lbeams :initform 0 :initarg :lbeams :accessor lbeams) (dots :initform 0 :initarg :dots :accessor dots))) -(defmethod print-gsharp-object :after ((e rhythmic-element) stream) +(defmethod print-gsharp-object progn ((e rhythmic-element) stream) (with-slots (notehead rbeams lbeams dots) e (format stream "~_:notehead ~W ~_:rbeams ~W ~_:lbeams ~W ~_:dots ~W " @@ -356,7 +358,7 @@ (ignore alterations)) (apply #'make-instance 'key-signature :staff staff args)) -(defmethod print-gsharp-object :after ((k key-signature) stream) +(defmethod print-gsharp-object progn ((k key-signature) stream) (with-slots (%staff %alterations) k (format stream "~_:staff ~W ~_:alterations ~W " %staff %alterations))) @@ -440,7 +442,7 @@ (ignore notehead lbeams rbeams dots xoffset notes stem-direction)) (apply #'make-instance 'cluster args)) -(defmethod print-gsharp-object :after ((c cluster) stream) +(defmethod print-gsharp-object progn ((c cluster) stream) (with-slots (stem-direction notes) c (format stream "~_:stem-direction ~W ~_:notes ~W " stem-direction notes))) @@ -526,7 +528,7 @@ (apply #'make-instance 'rest :staff staff args)) -(defmethod print-gsharp-object :after ((s rest) stream) +(defmethod print-gsharp-object progn ((s rest) stream) (with-slots (staff staff-pos) s (format stream "~_:staff ~W ~_:staff-pos ~W " staff staff-pos))) @@ -572,7 +574,7 @@ (apply #'make-instance 'lyrics-element :staff staff args)) -(defmethod print-gsharp-object :after ((elem lyrics-element) stream) +(defmethod print-gsharp-object progn ((elem lyrics-element) stream) (with-slots (staff text) elem (format stream "~_:staff ~W ~_:text ~W " staff text))) @@ -627,7 +629,7 @@ (loop for element in (elements b) do (setf (bar element) b))) -(defmethod print-gsharp-object :after ((b bar) stream) +(defmethod print-gsharp-object progn ((b bar) stream) (format stream "~_:elements ~W " (elements b))) ;;; The duration of a bar is simply the sum of durations @@ -750,7 +752,7 @@ (ignore bars)) (apply #'make-instance 'slice args)) -(defmethod print-gsharp-object :after ((s slice) stream) +(defmethod print-gsharp-object progn ((s slice) stream) (format stream "~_:bars ~W " (bars s))) (defun read-slice-v3 (stream char n) @@ -856,7 +858,7 @@ (layer (body l)) l (layer (tail l)) l)) -(defmethod print-gsharp-object :after ((l layer) stream) +(defmethod print-gsharp-object progn ((l layer) stream) (with-slots (head body tail staves) l (format stream "~_:staves ~W ~_:head ~W ~_:body ~W ~_:tail ~W " staves head body tail))) @@ -988,7 +990,7 @@ (loop for layer in layers do (setf (segment layer) s)))) -(defmethod print-gsharp-object :after ((s segment) stream) +(defmethod print-gsharp-object progn ((s segment) stream) (format stream "~_:layers ~W ~_:tempo ~W " (layers s) (tempo s))) (defun read-segment-v3 (stream char n) @@ -1106,7 +1108,7 @@ (loop for segment in segments do (setf (buffer segment) b)))) -(defmethod print-gsharp-object :after ((b buffer) stream) +(defmethod print-gsharp-object progn ((b buffer) stream) (with-slots (staves segments min-width spacing-style right-edge left-offset left-margin) b (format stream "~_:min-width ~W ~_:spacing-style ~W ~_:right-edge ~W ~_:left-offset ~W ~_:left-margin ~W ~_:staves ~W ~_:segments ~W "

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 16 Jan '07

16 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv21727 Modified Files: buffer.lisp Log Message: Untabify to make editing with Climacs easier. --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/09/14 14:34:47 1.39 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/01/16 05:21:39 1.40 @@ -54,14 +54,14 @@ (defclass clef (gsharp-object name-mixin) ((print-character :allocation :class :initform #\K) (lineno :reader lineno :initarg :lineno - :type (or (integer 2 6) null)))) + :type (or (integer 2 6) null)))) (defun make-clef (name &key lineno) (declare (type (member :treble :treble8 :bass :c :percussion) name) - (type (or (integer 2 6) null) lineno)) + (type (or (integer 2 6) null) lineno)) (when (null lineno) (setf lineno - (ecase name + (ecase name ((:treble :treble8) 2) (:bass 6) (:c 4) @@ -115,15 +115,15 @@ ((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)) + :initform (make-array 7 :initial-element :natural)) (key-signatures :accessor key-signatures :initform nil))) - + (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))))) + (make-instance 'key-signature :staff obj :alterations %keysig))))) (defun make-fiveline-staff (&rest args &key name clef keysig) (declare (ignore name clef keysig)) @@ -207,32 +207,32 @@ (pitch :initarg :pitch :reader pitch :type (integer 0 127)) (staff :initarg :staff :reader staff :type staff) (head :initform nil :initarg :head :reader head - :type (or (member :whole :half :filled) null)) + :type (or (member :whole :half :filled) null)) (accidentals :initform :natural :initarg :accidentals :reader accidentals - :type (member :natural :flat :double-flat - :sharp :double-sharp)) + :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) - (type staff staff) - (type (or (member :whole :half :filled) null) head) - (type (member :natural :flat :double-flat - :sharp :double-sharp) - accidentals) - (type (or (integer 0 3) null) dots) - (ignore head accidentals dots)) + (type staff staff) + (type (or (member :whole :half :filled) null) head) + (type (member :natural :flat :double-flat + :sharp :double-sharp) + accidentals) + (type (or (integer 0 3) null) dots) + (ignore head accidentals dots)) (apply #'make-instance 'note :pitch pitch :staff staff args)) (defmethod print-gsharp-object :after ((n note) stream) (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 ~W ~_:staff ~W ~_:head ~W ~_:accidentals ~W ~_:dots ~W ~ ~@[~_:tie-right ~W ~]~@[~_:tie-left ~W ~]" - pitch staff head accidentals dots %tie-right %tie-left))) + pitch staff head accidentals dots %tie-right %tie-left))) (defun read-note-v3 (stream char n) (declare (ignore char n)) @@ -265,7 +265,7 @@ (defmethod print-gsharp-object :after ((e element) stream) (with-slots (notehead rbeams lbeams dots xoffset) e (format stream - "~_:xoffset ~W " xoffset))) + "~_:xoffset ~W " xoffset))) (defmethod duration ((element element)) 0) (defmethod rbeams ((element element)) 0) @@ -304,21 +304,21 @@ (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 " - notehead rbeams lbeams dots))) + "~_:notehead ~W ~_:rbeams ~W ~_:lbeams ~W ~_:dots ~W " + notehead rbeams lbeams dots))) (defmethod undotted-duration ((element rhythmic-element)) (ecase (notehead element) (:whole 1) (:half 1/2) (:filled (/ (expt 2 (+ 2 (max (rbeams element) - (lbeams element)))))))) + (lbeams 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))) - ((zerop nb-dots)) + (nb-dots (dots element) (1- nb-dots))) + ((zerop nb-dots)) (incf duration dot-duration)) duration)) @@ -349,54 +349,54 @@ (defclass key-signature (element) ((%staff :initarg :staff :reader staff) (%alterations :initform (make-array 7 :initial-element :natural) - :initarg :alterations :reader alterations))) + :initarg :alterations :reader alterations))) (defun make-key-signature (staff &rest args &key alterations) (declare (type (or null (simple-vector 7)) alterations) - (ignore 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))) + "~_:staff ~W ~_:alterations ~W " %staff %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)))))) + 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)))))) - + 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 @@ -425,19 +425,19 @@ (defmethod initialize-instance :after ((c cluster) &rest args) (declare (ignore args)) (loop for note in (notes c) - do (setf (cluster note) c))) + do (setf (cluster note) c))) (defun make-cluster (&rest args - &key (notehead :filled) (lbeams 0) (rbeams 0) (dots 0) - (xoffset 0) notes (stem-direction :auto)) + &key (notehead :filled) (lbeams 0) (rbeams 0) (dots 0) + (xoffset 0) notes (stem-direction :auto)) (declare (type (member :whole :half :filled) notehead) - (type (integer 0 5) lbeams) - (type (integer 0 5) rbeams) - (type (integer 0 3) dots) - (type number xoffset) - (type list notes) - (type (member :up :down :auto) stem-direction) - (ignore notehead lbeams rbeams dots xoffset notes stem-direction)) + (type (integer 0 5) lbeams) + (type (integer 0 5) rbeams) + (type (integer 0 3) dots) + (type number xoffset) + (type list notes) + (type (member :up :down :auto) stem-direction) + (ignore notehead lbeams rbeams dots xoffset notes stem-direction)) (apply #'make-instance 'cluster args)) (defmethod print-gsharp-object :after ((c cluster) stream) @@ -463,10 +463,10 @@ (defmethod add-note ((cluster cluster) (note note)) (with-slots (notes) cluster (assert (not (find note notes :test #'note-equal)) - () - 'note-already-in-cluster) + () + 'note-already-in-cluster) (setf notes (merge 'list notes (list note) #'note-less) - (cluster note) cluster))) + (cluster note) cluster))) (defmethod find-note ((cluster cluster) (note note)) (with-slots (notes) cluster @@ -513,18 +513,18 @@ (staff-pos :initarg :staff-pos :initform 4 :reader staff-pos))) (defun make-rest (staff &rest args - &key (staff-pos 4) (notehead :filled) (lbeams 0) (rbeams 0) - (dots 0) (xoffset 0)) + &key (staff-pos 4) (notehead :filled) (lbeams 0) (rbeams 0) + (dots 0) (xoffset 0)) (declare (type staff staff) - (type integer staff-pos) - (type (member :whole :half :filled) notehead) - (type (integer 0 5) lbeams) - (type (integer 0 5) rbeams) - (type (integer 0 3) dots) - (type number xoffset) - (ignore staff-pos notehead lbeams rbeams dots xoffset)) + (type integer staff-pos) + (type (member :whole :half :filled) notehead) + (type (integer 0 5) lbeams) + (type (integer 0 5) rbeams) + (type (integer 0 3) dots) + (type number xoffset) + (ignore staff-pos notehead lbeams rbeams dots xoffset)) (apply #'make-instance 'rest - :staff staff args)) + :staff staff args)) (defmethod print-gsharp-object :after ((s rest) stream) (with-slots (staff staff-pos) s @@ -546,8 +546,8 @@ ((print-character :allocation :class :initform #\A) (staff :initarg :staff :reader staff) (text :initarg :text - :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0) - :reader text) + :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0) + :reader text) (%tie-right :initform nil :initarg :tie-right :accessor tie-right) (%tie-left :initform nil :initarg :tie-left :accessor tie-left))) @@ -556,21 +556,21 @@ (with-slots (text) elem (unless (adjustable-array-p text) (let ((length (length text))) - (setf text (make-array length :adjustable t :element-type 'fixnum - :fill-pointer length :initial-contents text)))))) + (setf text (make-array length :adjustable t :element-type 'fixnum + :fill-pointer length :initial-contents text)))))) (defun make-lyrics-element (staff &rest args - &key (notehead :filled) (lbeams 0) (rbeams 0) - (dots 0) (xoffset 0)) + &key (notehead :filled) (lbeams 0) (rbeams 0) + (dots 0) (xoffset 0)) (declare (type staff staff) - (type (member :whole :half :filled) notehead) - (type (integer 0 5) lbeams) - (type (integer 0 5) rbeams) - (type (integer 0 3) dots) - (type number xoffset) - (ignore notehead lbeams rbeams dots xoffset)) + (type (member :whole :half :filled) notehead) + (type (integer 0 5) lbeams) + (type (integer 0 5) rbeams) + (type (integer 0 3) dots) + (type number xoffset) + (ignore notehead lbeams rbeams dots xoffset)) (apply #'make-instance 'lyrics-element - :staff staff args)) + :staff staff args)) (defmethod print-gsharp-object :after ((elem lyrics-element) stream) (with-slots (staff text) elem @@ -625,7 +625,7 @@ (defmethod initialize-instance :after ((b bar) &rest args) (declare (ignore args)) (loop for element in (elements b) - do (setf (bar element) b))) + do (setf (bar element) b))) (defmethod print-gsharp-object :after ((b bar) stream) (format stream "~_:elements ~W " (elements b))) @@ -678,7 +678,7 @@ (defun make-melody-bar (&rest args &key elements) (declare (type list elements) - (ignore elements)) + (ignore elements)) (apply #'make-instance 'melody-bar args)) (defmethod make-bar-for-staff ((staff fiveline-staff) &rest args &key elements) @@ -698,7 +698,7 @@ (defun make-lyrics-bar (&rest args &key elements) (declare (type list elements) - (ignore elements)) + (ignore elements)) (apply #'make-instance 'lyrics-bar args)) (defmethod make-bar-for-staff ((staff lyrics-staff) &rest args &key elements) @@ -743,11 +743,11 @@ (defmethod initialize-instance :after ((s slice) &rest args) (declare (ignore args)) (loop for bar in (bars s) - do (setf (slice bar) s))) + do (setf (slice bar) s))) (defun make-slice (&rest args &key bars) (declare (type list bars) - (ignore bars)) + (ignore bars)) (apply #'make-instance 'slice args)) (defmethod print-gsharp-object :after ((s slice) stream) @@ -792,8 +792,8 @@ (with-slots (bars) slice (setf bars (delete bar bars :test #'eq)) (unless bars - ;; make sure there is one bar left - (add-bar (make-melody-bar) slice 0))) + ;; make sure there is one bar left + (add-bar (make-melody-bar) slice 0))) (setf slice nil))) (defmethod remove-bar ((bar lyrics-bar)) @@ -802,8 +802,8 @@ (with-slots (bars) slice (setf bars (delete bar bars :test #'eq)) (unless bars - ;; make sure there is one bar left - (add-bar (make-lyrics-bar) slice 0))) + ;; make sure there is one bar left + (add-bar (make-lyrics-bar) slice 0))) (setf slice nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -853,21 +853,21 @@ (unless tail (setf (tail l) (make-slice :bars (list (make-bar-for-staff staff)))))) (setf (layer (head l)) l - (layer (body l)) l - (layer (tail l)) l)) + (layer (body l)) l + (layer (tail l)) l)) (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 " [169 lines skipped]

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 16 Jan '07

16 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19540 Modified Files: gui.lisp Log Message: Replaced (current-buffer *application-frame*) by (current-buffer) as required by ESA now. Also, untabified to make editing with Climacs easier. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/11/16 12:58:23 1.73 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/01/16 05:17:40 1.74 @@ -2,9 +2,9 @@ (defun make-initial-cursor (buffer) (let* ((segment (segmentno buffer 0)) - (layer (layerno segment 0)) - (slice (body layer)) - (bar (barno slice 0))) + (layer (layerno segment 0)) + (slice (body layer)) + (bar (barno slice 0))) (make-cursor bar 0))) (defclass gsharp-minibuffer-pane (minibuffer-pane) @@ -30,7 +30,7 @@ (defclass gsharp-pane-mixin () ()) (defclass gsharp-pane (score-pane:score-pane gsharp-pane-mixin) - ((view :initarg :view :accessor view))) + ((view :initarg :view :accessor view))) (defvar *info-bg-color* +gray85+) (defvar *info-fg-color* +black+) @@ -45,82 +45,82 @@ (defun display-info (frame pane) (declare (ignore frame)) (let* ((master-pane (master-pane pane)) - (view (view master-pane)) - (buffer (buffer view))) + (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) + (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))) (princ " " pane) (format pane "[~a/~a]" - (score-pane:current-page-number view) - (score-pane:number-of-pages view)) + (score-pane:current-page-number view) + (score-pane:number-of-pages view)) (princ " " pane) (with-text-family (pane :sans-serif) (princ (if (recordingp *application-frame*) - "Def" - "") - pane)))) + "Def" + "") + pane)))) (define-application-frame gsharp (esa-frame-mixin - standard-application-frame) + standard-application-frame) ((views :initarg :views :initform '() :accessor views) (input-state :initarg :input-state :accessor input-state)) (: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)) - (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*))) - (vertically () - (scrolling (:width 750 :height 500 - :min-height 400 :max-height 20000) - win) - info))) + :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*))) + (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" - :display-function 'display-state)) + :width 50 :height 200 + :name "state" + :display-function 'display-state)) (element (make-pane 'score-pane:score-pane - :width 50 :height 300 - :min-height 100 :max-height 20000 - :name "element" - :display-function 'display-element)) + :width 50 :height 300 + :min-height 100 :max-height 20000 + :name "element" + :display-function 'display-element)) (interactor (make-pane 'gsharp-minibuffer-pane :width 900))) (:layouts (default (vertically () (horizontally () score - (vertically () - (scrolling (:width 80 :height 200) state) - (scrolling (:width 80 :height 300 - :min-height 300 :max-height 20000) - element))) + (vertically () + (scrolling (:width 80 :height 200) state) + (scrolling (:width 80 :height 300 + :min-height 300 :max-height 20000) + element))) interactor))) (:top-level (esa-top-level))) (defmethod buffers ((application-frame gsharp)) (remove-duplicates (mapcar (lambda (window) (buffer (view window))) - (windows application-frame)) - :test #'eq)) + (windows application-frame)) + :test #'eq)) (defmethod frame-current-buffer ((application-frame gsharp)) (buffer (view (car (windows application-frame))))) @@ -136,56 +136,56 @@ (let ((state (input-state *application-frame*))) (score-pane:with-score-pane pane (score-pane:with-staff-size 10 - (score-pane:with-vertical-score-position (pane 100) - (let ((xpos 30)) - (score-pane:draw-notehead pane (notehead state) xpos 4) - (when (not (eq (notehead state) :whole)) - (when (or (eq (stem-direction state) :auto) - (eq (stem-direction state) :down)) - (when (eq (notehead state) :filled) - (score-pane:with-notehead-left-offsets (left down) - (declare (ignore down)) - (let ((x (+ xpos left))) - (loop repeat (rbeams state) - for staff-step from -4 by 2 do - (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) - (loop repeat (lbeams state) - for staff-step from -4 by 2 do - (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) - (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4)))) - (when (or (eq (stem-direction state) :auto) - (eq (stem-direction state) :up)) - (when (eq (notehead state) :filled) - (score-pane:with-notehead-right-offsets (right up) - (declare (ignore up)) - (let ((x (+ xpos right))) - (loop repeat (rbeams state) - for staff-step downfrom 12 by 2 do - (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) - (loop repeat (lbeams state) - for staff-step downfrom 12 by 2 do - (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) - (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12))))) - (score-pane:with-notehead-right-offsets (right up) - (declare (ignore up)) - (loop repeat (dots state) - for dx from (+ right 5) by 5 do - (score-pane:draw-dot pane (+ xpos dx) 4))))))))) + (score-pane:with-vertical-score-position (pane 100) + (let ((xpos 30)) + (score-pane:draw-notehead pane (notehead state) xpos 4) + (when (not (eq (notehead state) :whole)) + (when (or (eq (stem-direction state) :auto) + (eq (stem-direction state) :down)) + (when (eq (notehead state) :filled) + (score-pane:with-notehead-left-offsets (left down) + (declare (ignore down)) + (let ((x (+ xpos left))) + (loop repeat (rbeams state) + for staff-step from -4 by 2 do + (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) + (loop repeat (lbeams state) + for staff-step from -4 by 2 do + (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) + (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4)))) + (when (or (eq (stem-direction state) :auto) + (eq (stem-direction state) :up)) + (when (eq (notehead state) :filled) + (score-pane:with-notehead-right-offsets (right up) + (declare (ignore up)) + (let ((x (+ xpos right))) + (loop repeat (rbeams state) + for staff-step downfrom 12 by 2 do + (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0)) + (loop repeat (lbeams state) + for staff-step downfrom 12 by 2 do + (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0))))) + (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12))))) + (score-pane:with-notehead-right-offsets (right up) + (declare (ignore up)) + (loop repeat (dots state) + for dx from (+ right 5) by 5 do + (score-pane:draw-dot pane (+ xpos dx) 4))))))))) (defun update-page-numbers (frame) (loop for window in (windows frame) - do (let ((page-number 0) - (view (view window))) - (gsharp-measure::new-map-over-obseq-subsequences - (lambda (all-measures) - (incf page-number) - (when (member-if (lambda (measure) (member (bar (cursor view)) - (measure-bars measure) - :test #'eq)) - all-measures) - (setf (score-pane:current-page-number view) page-number))) - (buffer view)) - (setf (score-pane:number-of-pages view) page-number)))) + do (let ((page-number 0) + (view (view window))) + (gsharp-measure::new-map-over-obseq-subsequences + (lambda (all-measures) + (incf page-number) + (when (member-if (lambda (measure) (member (bar (cursor view)) + (measure-bars measure) + :test #'eq)) + all-measures) + (setf (score-pane:current-page-number view) page-number))) + (buffer view)) + (setf (score-pane:number-of-pages view) page-number)))) ;;; I tried making this a :before method on redisplay-frame-panes, ;;; but it turns out that McCLIM calls redisplay-frame-pane from @@ -199,7 +199,7 @@ (let* ((buffer (buffer (view pane)))) (score-pane:with-score-pane pane (draw-buffer pane buffer (current-cursor) - (left-margin buffer) 100) + (left-margin buffer) 100) (gsharp-drawing::draw-the-cursor pane (current-cursor) (cursor-element (current-cursor)) (last-note (input-state *application-frame*))) (multiple-value-bind (minx miny maxx maxy) (bounding-rectangle* pane) @@ -224,30 +224,30 @@ (defmethod display-element ((frame gsharp) pane) (when (handler-case (cur-cluster) - (gsharp-condition () nil)) + (gsharp-condition () nil)) (score-pane:with-score-pane pane (score-pane:with-staff-size 10 - (score-pane:with-vertical-score-position (pane 500) - (let* ((xpos 30) - (cluster (cur-cluster)) - (notehead (notehead cluster)) - (rbeams (rbeams cluster)) - (lbeams (lbeams cluster)) - (dots (dots cluster)) - (notes (notes cluster)) - (stem-direction (stem-direction cluster))) - (declare (ignore stem-direction notehead lbeams rbeams dots)) - (loop for note in notes do - (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7) - (score-pane:draw-accidental pane (accidentals note) - (- xpos (if (oddp (note-position note)) 15 25)) - (* 3 (note-position note)))) - (when notes - (draw-ellipse* pane xpos (* 15 (note-position (cur-note))) - 7 0 0 7 :ink +red+)) - (loop for s from 0 by 30 - repeat 5 do - (draw-line* pane (- xpos 25) s (+ xpos 25) s)))))))) + (score-pane:with-vertical-score-position (pane 500) + (let* ((xpos 30) + (cluster (cur-cluster)) + (notehead (notehead cluster)) + (rbeams (rbeams cluster)) + (lbeams (lbeams cluster)) + (dots (dots cluster)) + (notes (notes cluster)) + (stem-direction (stem-direction cluster))) + (declare (ignore stem-direction notehead lbeams rbeams dots)) + (loop for note in notes do + (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7) + (score-pane:draw-accidental pane (accidentals note) + (- xpos (if (oddp (note-position note)) 15 25)) + (* 3 (note-position note)))) + (when notes + (draw-ellipse* pane xpos (* 15 (note-position (cur-note))) + 7 0 0 7 :ink +red+)) + (loop for s from 0 by 30 + repeat 5 do + (draw-line* pane (- xpos 25) s (+ xpos 25) s)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -265,15 +265,15 @@ 'menubar-command-table :errorp nil :menu '(("File" :menu file-command-table) - ("Buffer" :menu buffer-command-table) - ("Stuff" :menu segment-command-table) - ("Segment" :menu segment-command-table) - ("Layer" :menu layer-command-table) - ("Slice" :menu slice-command-table) - ("Measure" :menu measure-command-table) - ("Modes" :menu modes-command-table) - ("Staves" :menu staves-command-table) - ("Play" :menu play-command-table))) + ("Buffer" :menu buffer-command-table) + ("Stuff" :menu segment-command-table) + ("Segment" :menu segment-command-table) + ("Layer" :menu layer-command-table) + ("Slice" :menu slice-command-table) + ("Measure" :menu measure-command-table) + ("Modes" :menu modes-command-table) + ("Staves" :menu staves-command-table) + ("Play" :menu play-command-table))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -283,34 +283,34 @@ 'file-command-table :errorp nil :menu `(("Find" :command (esa-io::com-find-file ,esa::*unsupplied-argument-marker*)) - ("Save" :command esa-io::com-save-buffer) - ("Save as" :command (esa-io::com-write-buffer ,esa::*unsupplied-argument-marker*)) - ("Quit" :command com-quit))) + ("Save" :command esa-io::com-save-buffer) + ("Save as" :command (esa-io::com-write-buffer ,esa::*unsupplied-argument-marker*)) + ("Quit" :command com-quit))) (define-gsharp-command (com-new-buffer :name t) () (let* ((buffer (make-instance 'buffer)) - (cursor (make-initial-cursor buffer)) - (staff (car (staves buffer))) - (input-state (make-input-state)) - (view (make-instance 'orchestra-view - :buffer buffer - :cursor cursor))) + (cursor (make-initial-cursor buffer)) + (staff (car (staves buffer))) + (input-state (make-input-state)) + (view (make-instance 'orchestra-view + :buffer buffer + :cursor cursor))) (push view (views *application-frame*)) (setf (view (car (windows *application-frame*))) view) (setf (input-state *application-frame*) input-state - (staves (car (layers (car (segments buffer))))) (list staff)))) + (staves (car (layers (car (segments buffer))))) (list staff)))) (defmethod frame-find-file :around ((application-frame gsharp) filepath) (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))) + (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) + (input-state *application-frame*) input-state + (filepath buffer) filepath) (select-layer cursor (car (layers (segment (current-cursor))))))) (define-gsharp-command (com-quit :name t) () @@ -324,7 +324,7 @@ 'buffer-command-table :errorp nil :menu '(("Play" :command com-play-buffer) - ("Delete Current" :command com-delete-buffer))) [928 lines skipped]

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 16 Jan '07

16 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19010 Modified Files: modes.lisp Log Message: Make sure the file ends with a newline. Also, untabify to make it easier to edit with Climacs. --- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/08/02 02:14:44 1.20 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2007/01/16 05:11:09 1.21 @@ -104,12 +104,12 @@ (lambda () (append-char (cur-element) code))) (loop for c in '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M - #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) for i from 65 do (set-key (make-insert-fun i) 'lyrics-table `((,c)))) (loop for c in '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m - #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) for i from 97 do (set-key (make-insert-fun i) 'lyrics-table`((,c)))) @@ -178,6 +178,3 @@ (set-key (make-insert-fun 253) 'lyrics-table '((:dead--acute) (#\y))) (set-key (make-insert-fun 255) 'lyrics-table '((:dead--diaeresis :shift) (#\y))) - - - \ No newline at end of file

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 16 Jan '07

16 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv18442 Modified Files: beaming.lisp Log Message: Untabify to make it easier to work with Climacs. --- /project/gsharp/cvsroot/gsharp/beaming.lisp 2005/12/07 03:38:27 1.3 +++ /project/gsharp/cvsroot/gsharp/beaming.lisp 2007/01/16 05:06:20 1.4 @@ -27,75 +27,75 @@ ;;; is going to be acceptably small. (defun beaming-single-stemsup-rising-twonotes (pos1 pos2) (let ((d (- pos2 pos1)) - (s1 (+ pos2 1)) - (s2 (+ pos2 2)) - (s3 (+ pos2 3)) - (s4 (+ pos2 4)) - (s5 (+ pos2 5)) - (s6 (+ pos2 6))) + (s1 (+ pos2 1)) + (s2 (+ pos2 2)) + (s3 (+ pos2 3)) + (s4 (+ pos2 4)) + (s5 (+ pos2 5)) + (s6 (+ pos2 6))) (cond ((<= pos2 -3) (case d - (0 `((4 . -1) (4 . -1))) - (1 `((4 . -1) (4 . 0))) - (t `((4 . -1) (4 . 1))))) - ((= pos2 -2) (case d - (0 `((4 . 0) (4 . 0))) - (1 `((4 . -1) (4 . 0))) - (t `((4 . -1) (4 . 1))))) - ((= pos2 -1) (case d - (0 `((6 . -1) (6 . -1))) - (1 `((4 . 0) (4 . 1))) - (t `((4 . -1) (4 . 1))))) - ((<= pos2 8) (if (evenp pos2) - (list (case d - (0 `(,s6 . 0)) - (1 `(,s6 . -1)) - (2 `(,s4 . 0)) - (t `(,s4 . -1))) - `(,s6 . 0)) - (list (case d - (0 `(,s5 . 1)) - (1 `(,s5 . 0)) - (2 `(,s5 . -1)) - (t `(,s3 . 0))) - `(,s5 . 1)))) - ((evenp pos2) (list (case d - (0 `(,s4 . 1)) - (1 `(,s4 . 0)) - (2 `(,s4 . -1)) - ((3 4 5) `(,s2 . 0)) - (t `(,s2 . -1))) - `(,s4 . 1))) - (t (list (case d - (0 `(,s5 . 0)) - (1 `(,s5 . -1)) - (2 `(,s3 . 0)) - ((3 4 5 6) `(,s3 . -1)) - (t `(,s1 . 0))) - `(,s5 . 0)))))) + (0 `((4 . -1) (4 . -1))) + (1 `((4 . -1) (4 . 0))) + (t `((4 . -1) (4 . 1))))) + ((= pos2 -2) (case d + (0 `((4 . 0) (4 . 0))) + (1 `((4 . -1) (4 . 0))) + (t `((4 . -1) (4 . 1))))) + ((= pos2 -1) (case d + (0 `((6 . -1) (6 . -1))) + (1 `((4 . 0) (4 . 1))) + (t `((4 . -1) (4 . 1))))) + ((<= pos2 8) (if (evenp pos2) + (list (case d + (0 `(,s6 . 0)) + (1 `(,s6 . -1)) + (2 `(,s4 . 0)) + (t `(,s4 . -1))) + `(,s6 . 0)) + (list (case d + (0 `(,s5 . 1)) + (1 `(,s5 . 0)) + (2 `(,s5 . -1)) + (t `(,s3 . 0))) + `(,s5 . 1)))) + ((evenp pos2) (list (case d + (0 `(,s4 . 1)) + (1 `(,s4 . 0)) + (2 `(,s4 . -1)) + ((3 4 5) `(,s2 . 0)) + (t `(,s2 . -1))) + `(,s4 . 1))) + (t (list (case d + (0 `(,s5 . 0)) + (1 `(,s5 . -1)) + (2 `(,s3 . 0)) + ((3 4 5 6) `(,s3 . -1)) + (t `(,s1 . 0))) + `(,s5 . 0)))))) (defun beaming-double-stemsup-rising-twonotes (pos1 pos2) (let ((d (- pos2 pos1)) - (s4 (+ pos2 4)) - (s5 (+ pos2 5)) - (s6 (+ pos2 6)) - (s7 (+ pos2 7))) + (s4 (+ pos2 4)) + (s5 (+ pos2 5)) + (s6 (+ pos2 6)) + (s7 (+ pos2 7))) (cond ((<= pos2 -3) (case d - (0 `((4 . -1) (4 . -1))) - (t `((4 . -1) (4 . 0))))) - ((= pos2 -2) (case d - (0 `((4 . 0) (4 . 0))) - (t `((4 . -1) (4 . 0))))) - ((evenp pos2) (list (case d - (0 `(,s6 . 0)) - (1 `(,s6 . -1)) - (2 `(,s4 . 0)) - (t `(,s4 . -1))) - `(,s6 . 0))) - (t (case d - (0 `((,s7 . -1) (,s7 . -1))) - (1 `((,s7 . -1) (,s7 . 0))) - (2 `((,s5 . -1) (,s7 . -1))) - (t `((,s5 . -1) (,s7 . 0)))))))) + (0 `((4 . -1) (4 . -1))) + (t `((4 . -1) (4 . 0))))) + ((= pos2 -2) (case d + (0 `((4 . 0) (4 . 0))) + (t `((4 . -1) (4 . 0))))) + ((evenp pos2) (list (case d + (0 `(,s6 . 0)) + (1 `(,s6 . -1)) + (2 `(,s4 . 0)) + (t `(,s4 . -1))) + `(,s6 . 0))) + (t (case d + (0 `((,s7 . -1) (,s7 . -1))) + (1 `((,s7 . -1) (,s7 . 0))) + (2 `((,s5 . -1) (,s7 . -1))) + (t `((,s5 . -1) (,s7 . 0)))))))) (defun reflect-pos (pos) (destructuring-bind (p x b) pos @@ -113,16 +113,16 @@ ;;; higher vertical position of the first point. (defun beaming-two-points (p1 p2 fun) (let* ((beaming (funcall fun (car p1) (car p2))) - (left (car beaming)) - (right (cadr beaming)) - (x1 (cadr p1)) - (x2 (cadr p2)) - (y1 (+ (car left) (* 0.5 (cdr left)))) - (y2 (+ (car right) (* 0.5 (cdr right)))) - (slant (/ (- y2 y1) (abs (- x2 x1))))) + (left (car beaming)) + (right (cadr beaming)) + (x1 (cadr p1)) + (x2 (cadr p2)) + (y1 (+ (car left) (* 0.5 (cdr left)))) + (y2 (+ (car right) (* 0.5 (cdr right)))) + (slant (/ (- y2 y1) (abs (- x2 x1))))) (if (> slant #.(tan (/ (* 18 pi) 180))) - (progn (incf (car p1)) (beaming-two-points p1 p2 fun)) - beaming))) + (progn (incf (car p1)) (beaming-two-points p1 p2 fun)) + beaming))) ;;; main entry @@ -138,26 +138,26 @@ ;;; until each stem it as least 2.5 staff steps long. (defun beaming-general (positions stem-direction fun) (let* ((first (car positions)) - (last (car (last positions))) - (x1 (cadr first)) - (x2 (cadr last))) + (last (car (last positions))) + (x1 (cadr first)) + (x2 (cadr last))) (cond ((> (car first) (car last)) - (reverse (beaming-general (reverse positions) stem-direction fun))) - ((eq stem-direction :down) - (mapcar #'reflect-bpos (beaming-general (mapcar #'reflect-pos positions) :up fun))) - (t (let* ((beaming (beaming-two-points first last fun)) - (left (car beaming)) - (right (cadr beaming)) - (y1 (+ (car left) (* 0.5 (cdr left)))) - (y2 (+ (car right) (* 0.5 (cdr right)))) - (slope (/ (- y2 y1) (- x2 x1))) - (minstem (reduce #'min positions - :key (lambda (pos) - (destructuring-bind (p x b) pos - (- (+ y1 (* (- x x1) slope)) p (* 2 (1- b))))))) - (increment (* 2 (ceiling (/ (max 0 (- 5 minstem)) 2))))) - `((,(+ (car left) increment) . ,(cdr left)) - (,(+ (car right) increment) . ,(cdr right)))))))) + (reverse (beaming-general (reverse positions) stem-direction fun))) + ((eq stem-direction :down) + (mapcar #'reflect-bpos (beaming-general (mapcar #'reflect-pos positions) :up fun))) + (t (let* ((beaming (beaming-two-points first last fun)) + (left (car beaming)) + (right (cadr beaming)) + (y1 (+ (car left) (* 0.5 (cdr left)))) + (y2 (+ (car right) (* 0.5 (cdr right)))) + (slope (/ (- y2 y1) (- x2 x1))) + (minstem (reduce #'min positions + :key (lambda (pos) + (destructuring-bind (p x b) pos + (- (+ y1 (* (- x x1) slope)) p (* 2 (1- b))))))) + (increment (* 2 (ceiling (/ (max 0 (- 5 minstem)) 2))))) + `((,(+ (car left) increment) . ,(cdr left)) + (,(+ (car right) increment) . ,(cdr right)))))))) (defun beaming-single (positions stem-direction) (beaming-general positions stem-direction #'beaming-single-stemsup-rising-twonotes))

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 07 Jan '07

07 Jan '07

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv14102 Modified Files: drawing.lisp Log Message: Fixed a problem with displaying fractional beams when a beam group contains elements other than clusters (such as rests). --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2006/06/26 16:37:43 1.73 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2007/01/07 06:05:35 1.74 @@ -629,6 +629,16 @@ (if (< (pitch n1) (pitch n2)) n1 n2)))))) notes)) +(defun cluster-p (element) + (typep element 'cluster)) + +(defun map-over-cluster-pairs (fun list) + (loop for sublist on list + do (when (cluster-p (car sublist)) + (let ((second (find-if #'cluster-p (cdr sublist)))) + (when second + (funcall fun (car sublist) second)))))) + (defun draw-beam-group (pane elements) (let ((e (car elements))) (when (typep e 'gsharp-buffer::key-signature) @@ -694,28 +704,29 @@ (loop for beams from (1+ min-nb-beams) to max-nb-beams for ss from (* 2 min-nb-beams) by 2 for offset from min-nb-beams - do (loop for (e1 e2) on elements - do (when (not (null e2)) - (cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams)) - (setf region - (region-union region - (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000 - (+ (final-absolute-element-xoffset e2) right) 10000)))) - ((>= (rbeams e1) beams) - (setf region - (region-union region - (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000 - (+ (final-absolute-element-xoffset e1) right (score-pane:staff-step 2)) 10000)))) - ((>= (lbeams e2) beams) - (setf region - (region-union region - (make-rectangle* (+ (final-absolute-element-xoffset e2) right (score-pane:staff-step -2)) -10000 - (+ (final-absolute-element-xoffset e2) right) 10000)))) - (t nil)))) - (with-drawing-options (pane :clipping-region region) - (score-pane:draw-beam pane - (+ (final-absolute-element-xoffset (car elements)) right) (- ss1 ss) (+ offset1 offset) - (+ (final-absolute-element-xoffset (car (last elements))) right) (- ss2 ss) (+ offset2 offset)))))) + do (map-over-cluster-pairs + (lambda (e1 e2) + (cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams)) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000 + (+ (final-absolute-element-xoffset e2) right) 10000)))) + ((>= (rbeams e1) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) right) -10000 + (+ (final-absolute-element-xoffset e1) right (score-pane:staff-step 2)) 10000)))) + ((>= (lbeams e2) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e2) right (score-pane:staff-step -2)) -10000 + (+ (final-absolute-element-xoffset e2) right) 10000)))) + (t nil))) + elements) + (with-drawing-options (pane :clipping-region region) + (score-pane:draw-beam pane + (+ (final-absolute-element-xoffset (car elements)) right) (- ss1 ss) (+ offset1 offset) + (+ (final-absolute-element-xoffset (car (last elements))) right) (- ss2 ss) (+ offset2 offset)))))) (score-pane:with-notehead-left-offsets (left down) (declare (ignore down)) (loop repeat min-nb-beams @@ -728,24 +739,25 @@ (loop for beams from (1+ min-nb-beams) to max-nb-beams for ss from (* 2 min-nb-beams) by 2 for offset from min-nb-beams - do (loop for (e1 e2) on elements - do (when (not (null e2)) - (cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams)) - (setf region - (region-union region - (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000 - (+ (final-absolute-element-xoffset e2) left) 10000)))) - ((>= (rbeams e1) beams) - (setf region - (region-union region - (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000 - (+ (final-absolute-element-xoffset e1) left (score-pane:staff-step 2)) 10000)))) - ((>= (lbeams e2) beams) - (setf region - (region-union region - (make-rectangle* (+ (final-absolute-element-xoffset e2) left (score-pane:staff-step -2)) -10000 - (+ (final-absolute-element-xoffset e2) left) 10000)))) - (t nil)))) + do (map-over-cluster-pairs + (lambda (e1 e2) + (cond ((and (>= (rbeams e1) beams) (>= (lbeams e2) beams)) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000 + (+ (final-absolute-element-xoffset e2) left) 10000)))) + ((>= (rbeams e1) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e1) left) -10000 + (+ (final-absolute-element-xoffset e1) left (score-pane:staff-step 2)) 10000)))) + ((>= (lbeams e2) beams) + (setf region + (region-union region + (make-rectangle* (+ (final-absolute-element-xoffset e2) left (score-pane:staff-step -2)) -10000 + (+ (final-absolute-element-xoffset e2) left) 10000)))) + (t nil))) + elements) (with-drawing-options (pane :clipping-region region) (score-pane:draw-beam pane (+ (final-absolute-element-xoffset (car elements)) left) (+ ss1 ss) (- offset1 offset)

1 0