[gsharp-cvs] CVS update: gsharp/buffer.lisp gsharp/gui.lisp gsharp/packages.lisp
Robert Strandh
rstrandh at common-lisp.net
Wed Nov 2 05:01:18 UTC 2005
Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp.net:/tmp/cvs-serv22023
Modified Files:
buffer.lisp gui.lisp packages.lisp
Log Message:
Put back some of the constructor functions.
Added more documentation about buffer protocols.
Date: Wed Nov 2 06:01:11 2005
Author: rstrandh
Index: gsharp/buffer.lisp
diff -u gsharp/buffer.lisp:1.20 gsharp/buffer.lisp:1.21
--- gsharp/buffer.lisp:1.20 Tue Nov 1 19:08:02 2005
+++ gsharp/buffer.lisp Wed Nov 2 06:01:10 2005
@@ -38,18 +38,18 @@
(lineno :reader lineno :initarg :lineno
:type (or (integer 2 6) null))))
-(defmethod initialize-instance :after ((c clef) &rest args)
- (declare (ignore args))
- (with-slots (lineno name) c
- (check-type name (member :treble :bass :c :percussion))
- (unless (slot-boundp c 'lineno)
- (setf lineno
- (ecase name
+(defun make-clef (name &key lineno)
+ (declare (type (member :treble :bass :c :percussion) name)
+ (type (or (integer 2 6) null) lineno))
+ (when (null lineno)
+ (setf lineno
+ (ecase name
(:treble 2)
(:bass 6)
(:c 4)
- (:percussion 3))))))
-
+ (:percussion 3))))
+ (make-instance 'clef :name name :lineno lineno))
+
(defmethod print-object :after ((c clef) stream)
(format stream ":lineno ~W " (lineno c)))
@@ -75,12 +75,14 @@
(defclass fiveline-staff (staff)
((print-character :allocation :class :initform #\=)
- (clef :accessor clef :initarg :clef :initform (make-instance 'clef :name :treble))
+ (clef :accessor clef :initarg :clef :initform (make-clef :treble))
(keysig :accessor keysig :initarg :keysig
- :initform (make-array 7 :initial-element :natural)))
- (:default-initargs
- :name "default staff"))
+ :initform (make-array 7 :initial-element :natural))))
+(defun make-fiveline-staff (&rest args &key name clef keysig)
+ (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)))
@@ -97,6 +99,10 @@
(defclass lyrics-staff (staff)
((print-character :allocation :class :initform #\L)))
+(defun make-lyrics-staff (&rest args &key name)
+ (declare (ignore name))
+ (apply #'make-instance 'lyrics-staff args))
+
(defun read-lyrics-staff-v3 (stream char n)
(declare (ignore char n))
(apply #'make-instance 'lyrics-staff (read-delimited-list #\] stream t)))
@@ -152,15 +158,26 @@
(defclass note (gsharp-object)
((print-character :allocation :class :initform #\N)
(cluster :initform nil :initarg :cluster :accessor cluster)
- (pitch :initarg :pitch :reader pitch :type (integer 0 128))
- (staff :initarg :staff :reader staff :type (or staff null))
+ (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))
(accidentals :initform :natural :initarg :accidentals :reader accidentals
:type (member :natural :flat :double-flat
:sharp :double-sharp))
(dots :initform nil :initarg :dots :reader dots
- :type (or integer null))))
+ :type (or (integer 0 3) null))))
+
+(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))
+ (apply #'make-instance 'note :pitch pitch :staff staff args))
(defmethod print-object :after ((n note) stream)
(with-slots (pitch staff head accidentals dots) n
@@ -214,10 +231,10 @@
(defclass element (gsharp-object)
((bar :initform nil :initarg :bar :accessor bar)
- (notehead :initarg :notehead :accessor notehead)
- (rbeams :initarg :rbeams :accessor rbeams)
- (lbeams :initarg :lbeams :accessor lbeams)
- (dots :initarg :dots :accessor dots)
+ (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)))
(defmethod print-object :after ((e element) stream)
@@ -270,14 +287,26 @@
(defclass cluster (melody-element)
((print-character :allocation :class :initform #\%)
(notes :initform '() :initarg :notes :accessor notes)
- (stem-direction :initarg :stem-direction :accessor stem-direction)
- (stem-length :initform nil :initarg :stem-length :accessor stem-length)))
+ (stem-direction :initform :auto :initarg :stem-direction :accessor stem-direction)))
(defmethod initialize-instance :after ((c cluster) &rest args)
(declare (ignore args))
(loop for note in (notes 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))
+ (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))
+ (apply #'make-instance 'cluster args))
+
(defmethod print-object :after ((c cluster) stream)
(with-slots (stem-direction notes) c
(format stream ":stem-direction ~W :notes ~W " stem-direction notes)))
@@ -332,6 +361,20 @@
(staff :initarg :staff :reader staff)
(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))
+ (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))
+ (apply #'make-instance 'rest
+ :staff staff args))
+
(defmethod print-object :after ((s rest) stream)
(with-slots (staff staff-pos) s
(format stream ":staff ~W :staff-pos ~W " staff staff-pos)))
@@ -842,7 +885,7 @@
(defclass buffer (gsharp-object)
((print-character :allocation :class :initform #\B)
(segments :initform '() :initarg :segments :accessor segments)
- (staves :initform (list (make-instance 'fiveline-staff))
+ (staves :initform (list (make-fiveline-staff))
:initarg :staves :accessor staves)
(min-width :initform *default-min-width* :initarg :min-width :accessor min-width)
(spacing-style :initform *default-spacing-style* :initarg :spacing-style :accessor spacing-style)
Index: gsharp/gui.lisp
diff -u gsharp/gui.lisp:1.36 gsharp/gui.lisp:1.37
--- gsharp/gui.lisp:1.36 Tue Nov 1 19:08:02 2005
+++ gsharp/gui.lisp Wed Nov 2 06:01:10 2005
@@ -165,9 +165,8 @@
(lbeams (lbeams cluster))
(dots (dots cluster))
(notes (notes cluster))
- (stem-direction (stem-direction cluster))
- (stem-length (stem-length cluster)))
- (declare (ignore stem-direction stem-length notehead lbeams rbeams dots))
+ (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)
@@ -564,12 +563,12 @@
(defun insert-cluster ()
(let* ((state (input-state *application-frame*))
(cursor (cursor *application-frame*))
- (cluster (make-instance 'cluster
- :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
- :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
- :dots (dots state)
- :notehead (notehead state)
- :stem-direction (stem-direction state))))
+ (cluster (make-cluster
+ :notehead (notehead state)
+ :lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
+ :rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
+ :dots (dots state)
+ :stem-direction (stem-direction state))))
(insert-element cluster cursor)
(forward-element cursor)
cluster))
@@ -580,9 +579,7 @@
(defun insert-note (pitch cluster)
(let* ((state (input-state *application-frame*))
(staff (car (staves (layer (slice (bar cluster))))))
- (note (make-instance 'note
- :pitch pitch
- :staff staff
+ (note (make-note pitch staff
:head (notehead state)
:accidentals (aref (keysig staff) (mod pitch 7))
:dots (dots state))))
@@ -627,12 +624,11 @@
(define-gsharp-command com-insert-rest ()
(let* ((state (input-state *application-frame*))
(cursor (cursor *application-frame*))
- (rest (make-instance 'rest
+ (rest (make-rest (car (staves (layer (cursor *application-frame*))))
:rbeams (if (eq (notehead state) :filled) (rbeams state) 0)
:lbeams (if (eq (notehead state) :filled) (lbeams state) 0)
:dots (dots state)
- :notehead (notehead state)
- :staff (car (staves (layer (cursor *application-frame*)))))))
+ :notehead (notehead state))))
(insert-element rest cursor)
(forward-element cursor)
rest))
@@ -735,9 +731,7 @@
(let ((element (cur-element)))
(if (typep element 'cluster)
(let* ((note (cur-note))
- (new-note (make-instance 'note
- :pitch (1- (pitch note))
- :staff (staff note)
+ (new-note (make-note (1- (pitch note)) (staff note)
:head (head note)
:accidentals (accidentals note)
:dots (dots note))))
@@ -753,10 +747,10 @@
(cursor (cursor *application-frame*)))
(backward-element cursor)
(delete-element cursor)
- (insert-element (make-instance 'rest
+ (insert-element (make-rest staff
+ :staff-pos (- staff-pos 2)
:notehead notehead :dots dots
- :rbeams rbeams :lbeams lbeams
- :staff staff :staff-pos (- staff-pos 2))
+ :rbeams rbeams :lbeams lbeams)
cursor)
(forward-element cursor)))))
@@ -764,9 +758,7 @@
(let ((element (cur-element)))
(if (typep element 'cluster)
(let* ((note (cur-note))
- (new-note (make-instance 'note
- :pitch (1+ (pitch note))
- :staff (staff note)
+ (new-note (make-note (1+ (pitch note)) (staff note)
:head (head note)
:accidentals (accidentals note)
:dots (dots note))))
@@ -782,19 +774,17 @@
(cursor (cursor *application-frame*)))
(backward-element cursor)
(delete-element cursor)
- (insert-element (make-instance 'rest
+ (insert-element (make-rest staff
+ :staff-pos (+ staff-pos 2)
:notehead notehead :dots dots
- :rbeams rbeams :lbeams lbeams
- :staff staff :staff-pos (+ staff-pos 2))
+ :rbeams rbeams :lbeams lbeams)
cursor)
(forward-element cursor)))))
(define-gsharp-command com-sharper ()
(let* ((cluster (cur-cluster))
(note (cur-note))
- (new-note (make-instance 'note
- :pitch (pitch note)
- :staff (staff note)
+ (new-note (make-note (pitch note) (staff note)
:head (head note)
:accidentals (ecase (accidentals note)
(:double-sharp :double-sharp)
@@ -810,9 +800,7 @@
(define-gsharp-command com-flatter ()
(let* ((cluster (cur-cluster))
(note (cur-note))
- (new-note (make-instance 'note
- :pitch (pitch note)
- :staff (staff note)
+ (new-note (make-note (pitch note) (staff note)
:head (head note)
:accidentals (ecase (accidentals note)
(:double-sharp :sharp)
@@ -925,7 +913,7 @@
(let ((staff (accept 'score-pane:fiveline-staff :prompt "Set clef of staff"))
(type (accept 'clef-type :prompt "Type of clef"))
(line (accept 'integer :prompt "Line of clef")))
- (setf (clef staff) (make-instance 'clef :name type :lineno line))))
+ (setf (clef staff) (make-clef type :lineno line))))
(define-gsharp-command com-higher ()
(incf (last-note (input-state *application-frame*)) 7))
@@ -1054,9 +1042,9 @@
(ecase (accept 'staff-type :prompt "Type")
(:fiveline (let* ((clef-name (accept 'clef-type :prompt "Clef type of new staff"))
(line (accept 'integer :prompt "Line of clef"))
- (clef (make-instance 'clef :name clef-name :lineno line)))
- (make-instance 'fiveline-staff :name name :clef clef)))
- (:lyrics (make-instance 'lyrics-staff :name name)))))
+ (clef (make-clef clef-name :lineno line)))
+ (make-fiveline-staff :name name :clef clef)))
+ (:lyrics (make-lyrics-staff :name name)))))
(define-gsharp-command (com-insert-staff-before :name t) ()
(add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff before staff")
Index: gsharp/packages.lisp
diff -u gsharp/packages.lisp:1.22 gsharp/packages.lisp:1.23
--- gsharp/packages.lisp:1.22 Tue Nov 1 19:08:02 2005
+++ gsharp/packages.lisp Wed Nov 2 06:01:10 2005
@@ -36,16 +36,18 @@
(defpackage :gsharp-buffer
(:use :common-lisp :gsharp-utilities)
(:shadow #:rest)
- (:export #:clef #:name #:lineno
- #:staff #:fiveline-staff
- #:lyrics-staff
+ (:export #:clef #:name #:lineno #:make-clef
+ #:staff #:fiveline-staff #:make-fiveline-staff
+ #:lyrics-staff #:make-lyrics-staff
#:gsharp-condition
- #:pitch #:accidentals #:dots #:note
+ #:pitch #:accidentals #:dots #:note #:make-note
#:note-less #:note-equal #:bar
#:notehead #:rbeams #:lbeams #:dots #:element
#:melody-element #:notes
- #:add-note #:find-note #:remove-note #:cluster
- #:rest #:lyrics-element
+ #:add-note #:find-note #:remove-note
+ #:cluster #:make-cluster
+ #:rest #:make-rest
+ #:lyrics-element #:make-lyrics-element
#:slice #:elements
#:nb-elements #:elementno #:add-element
#:remove-element #:bar #:make-bar
@@ -64,7 +66,7 @@
#:rename-staff
#:add-staff-to-layer
#:remove-staff-from-layer
- #:stem-direction #:stem-length #:undotted-duration #:duration
+ #:stem-direction #:undotted-duration #:duration
#:clef #:keysig #:staff-pos #:xoffset #:read-everything #:save-buffer-to-stream
#:line-width #:min-width #:spacing-style #:right-edge #:left-offset
#:left-margin #:text #:append-char #:erase-char
More information about the Gsharp-cvs
mailing list