Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv22660

Modified Files: buffer.lisp gui.lisp packages.lisp Log Message: Improved on the constructors for buffer-related classes.

Date: Mon Nov 7 21:00:52 2005 Author: rstrandh

Index: gsharp/buffer.lisp diff -u gsharp/buffer.lisp:1.23 gsharp/buffer.lisp:1.24 --- gsharp/buffer.lisp:1.23 Thu Nov 3 04:40:13 2005 +++ gsharp/buffer.lisp Mon Nov 7 21:00:52 2005 @@ -477,6 +477,8 @@ (defmethod print-object :after ((b bar) stream) (format stream ":elements ~W " (elements b)))

+(defgeneric make-bar-for-staff (staff &rest args &key elements)) + (defmethod nb-elements ((bar bar)) (length (elements bar)))

@@ -518,6 +520,10 @@ (ignore elements)) (apply #'make-instance 'melody-bar args))

+(defmethod make-bar-for-staff ((staff fiveline-staff) &rest args &key elements) + (declare (ignore elements)) + (apply #'make-instance 'melody-bar args)) + (defun read-melody-bar-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'melody-bar (read-delimited-list #] stream t))) @@ -534,6 +540,10 @@ (ignore elements)) (apply #'make-instance 'lyrics-bar args))

+(defmethod make-bar-for-staff ((staff lyrics-staff) &rest args &key elements) + (declare (ignore elements)) + (apply #'make-instance 'lyrics-bar args)) + (defun read-lyrics-bar-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'lyrics-bar (read-delimited-list #] stream t))) @@ -672,8 +682,15 @@ (tail :initarg :tail :accessor tail)) (:default-initargs :name "default layer"))

-(defmethod initialize-instance :after ((l layer) &rest args) +(defmethod initialize-instance :after ((l layer) &rest args &key head body tail) (declare (ignore args)) + (let ((staff (car (staves l)))) + (unless head + (setf (head l) (make-slice :bars (list (make-bar-for-staff staff))))) + (unless body + (setf (body l) (make-slice :bars (list (make-bar-for-staff staff))))) + (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)) @@ -683,25 +700,19 @@ (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)) + +(defun make-layer (staves &rest args &key head body tail) + (declare (type list staves) + (type (or slice null) head body tail) + (ignore head body tail)) + (apply #'make-layer-for-staff (car staves) :staves staves args)) + ;;; melody layer

(defclass melody-layer (layer) ((print-character :allocation :class :initform #_)))

-(defmethod make-layer (name (initial-staff fiveline-staff)) - (flet ((make-initialized-slice () - (make-slice :bars (list (make-melody-bar))))) - (let* ((head (make-initialized-slice)) - (body (make-initialized-slice)) - (tail (make-initialized-slice)) - (result (make-instance 'melody-layer - :name name :staves (list initial-staff) - :head head :body body :tail tail))) - (setf (slot-value head 'layer) result - (slot-value body 'layer) result - (slot-value tail 'layer) result) - result))) - (defun read-melody-layer-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'melody-layer (read-delimited-list #] stream t))) @@ -710,25 +721,15 @@ #'read-melody-layer-v3 *gsharp-readtable-v3*)

+(defmethod make-layer-for-staff ((staff fiveline-staff) &rest args &key staves head body tail) + (declare (ignore staves head body tail)) + (apply #'make-instance 'melody-layer args)) + ;;; lyrics layer

(defclass lyrics-layer (layer) ((print-character :allocation :class :initform #\M)))

-(defmethod make-layer (name (initial-staff lyrics-staff)) - (flet ((make-initialized-slice () - (make-slice :bars (list (make-lyrics-bar))))) - (let* ((head (make-initialized-slice)) - (body (make-initialized-slice)) - (tail (make-initialized-slice)) - (result (make-instance 'lyrics-layer - :name name :staves (list initial-staff) - :head head :body body :tail tail))) - (setf (slot-value head 'layer) result - (slot-value body 'layer) result - (slot-value tail 'layer) result) - result))) - (defun read-lyrics-layer-v3 (stream char n) (declare (ignore char n)) (apply #'make-instance 'lyrics-layer (read-delimited-list #] stream t))) @@ -737,6 +738,10 @@ #'read-lyrics-layer-v3 *gsharp-readtable-v3*)

+(defmethod make-layer-for-staff ((staff lyrics-staff) &rest args &key staves head body tail) + (declare (ignore staves head body tail)) + (apply #'make-instance 'lyrics-layer args)) + (defmethod slices ((layer layer)) (with-slots (head body tail) layer (list head body tail))) @@ -817,7 +822,7 @@ (with-slots (layers) s (when (null layers) (assert (not (null staff))) - (push (make-layer "Default layer" staff) layers)) + (push (make-layer (list staff)) layers)) (loop for layer in layers do (setf (segment layer) s))))

@@ -864,7 +869,7 @@ (setf layers (delete layer layers :test #'eq)) ;; make sure there is one layer left (unless layers - (add-layer (make-layer "Default layer" (car (staves (buffer segment)))) + (add-layer (make-layer (staves (buffer segment))) segment))) (setf segment nil)))

Index: gsharp/gui.lisp diff -u gsharp/gui.lisp:1.39 gsharp/gui.lisp:1.40 --- gsharp/gui.lisp:1.39 Mon Nov 7 06:23:57 2005 +++ gsharp/gui.lisp Mon Nov 7 21:00:52 2005 @@ -441,7 +441,7 @@ (define-gsharp-command (com-add-layer :name t) () (let* ((name (acquire-unique-layer-name "Name of new layer")) (staff (accept 'score-pane:staff :prompt "Initial staff of new layer")) - (new-layer (make-layer name staff))) + (new-layer (make-layer staff :name name))) (add-layer new-layer (segment (cursor *application-frame*))) (select-layer (cursor *application-frame*) new-layer)))

Index: gsharp/packages.lisp diff -u gsharp/packages.lisp:1.25 gsharp/packages.lisp:1.26 --- gsharp/packages.lisp:1.25 Mon Nov 7 06:23:57 2005 +++ gsharp/packages.lisp Mon Nov 7 21:00:52 2005 @@ -55,8 +55,9 @@ #:lyrics-bar #:make-lyrics-bar #:layer #:lyrics-layer #:melody-layer #:bars #:nb-bars #:barno #:add-bar #:remove-bar - #:slice + #:slice #:make-slice #:segment #:slices #:sliceno + #:make-layer-for-staff #:make-bar-for-staff #:head #:body #:tail #:make-layer #:buffer #:layers #:nb-layers #:layerno #:add-layer #:remove-layer #:segment