Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp.net:/tmp/cvs-serv3372
Modified Files:
buffer.lisp
Log Message:
Factored out named objects in a mixin class
Cleaned up print-object by using method combination and a base
class for all buffer objects.
Date: Wed Aug 4 12:59:28 2004
Author: rstrandh
Index: gsharp/buffer.lisp
diff -u gsharp/buffer.lisp:1.6 gsharp/buffer.lisp:1.7
--- gsharp/buffer.lisp:1.6 Sat Jul 24 13:09:55 2004
+++ gsharp/buffer.lisp Wed Aug 4 12:59:28 2004
@@ -9,25 +9,38 @@
(defun skip-until-close-bracket (stream)
(loop until (eql (read-char stream) #\])))
+(defclass gsharp-object () ())
+
+(defmethod print-object ((obj gsharp-object) stream)
+ nil)
+
+(defmethod print-object :around ((obj gsharp-object) stream)
+ (format stream "[~a " (slot-value obj 'print-character))
+ (call-next-method)
+ (format 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)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clef
-;;; The name of a clef is one of :TREBLE, :BASS,
-;;; :C, and :PERCUSSION
-(defgeneric name (clef))
-
;;; The line number on which the clef is located on the staff.
;;; The bottom line of the staff is number 1.
(defgeneric lineno (clef))
-(defclass clef ()
- ((name :reader name :initarg :name :initform nil)
+(defclass clef (gsharp-object name-mixin)
+ ((print-character :allocation :class :initform #\K)
(lineno :reader lineno :initarg :lineno :initform nil)))
-(defmethod print-object ((c clef) stream)
- (with-slots (name lineno) c
- (format stream "[K :name ~W :lineno ~W ] " name lineno)))
+(defmethod print-object :after ((c clef) stream)
+ (format stream ":lineno ~W " (lineno c)))
(defun make-clef (name &optional lineno)
(declare (type (member :treble :bass :c :percussion) name)
@@ -64,21 +77,22 @@
;;;
;;; Staff
-(defclass staff ()
- ((name :accessor name :initarg :name :initform "default staff")))
+(defclass staff (gsharp-object name-mixin)
+ ()
+ (:default-initargs :name "default staff"))
;;; fiveline
(defgeneric clef (fiveline-staff))
(defclass fiveline-staff (staff)
- ((clef :accessor clef :initarg :clef :initform nil)
+ ((print-character :allocation :class :initform #\=)
+ (clef :accessor clef :initarg :clef :initform nil)
(keysig :accessor keysig :initarg :keysig
:initform (make-array 7 :initial-element :natural))))
-(defmethod print-object ((s fiveline-staff) stream)
- (with-slots (name clef keysig) s
- (format stream "[= :name ~W :clef ~W :keysig ~W ] " name clef keysig)))
+(defmethod print-object :after ((s fiveline-staff) stream)
+ (format stream ":clef ~W :keysig ~W " (clef s) (keysig s)))
(defun make-fiveline-staff (name &optional (clef (make-clef :treble)))
(make-instance 'fiveline-staff :name name :clef clef))
@@ -105,11 +119,7 @@
;;; lyric
(defclass lyrics-staff (staff)
- ())
-
-(defmethod print-object ((s lyrics-staff) stream)
- (with-slots (name) s
- (format stream "[L :name ~W ] " name)))
+ ((print-character :allocation :class :initform #\L)))
(defun make-lyrics-staff (name)
(make-instance 'lyrics-staff :name name))
@@ -146,18 +156,19 @@
;;; currently does not belong to any cluster.
(defgeneric cluster (note))
-(defclass note ()
- ((cluster :initform nil :initarg :cluster :accessor cluster)
+(defclass note (gsharp-object)
+ ((print-character :allocation :class :initform #\N)
+ (cluster :initform nil :initarg :cluster :accessor cluster)
(pitch :initarg :pitch :reader pitch)
(staff :initarg :staff :reader staff)
(head :initarg :head :reader head)
(accidentals :initarg :accidentals :reader accidentals)
(dots :initarg :dots :reader dots)))
-(defmethod print-object ((n note) stream)
+(defmethod print-object :after ((n note) stream)
(with-slots (pitch staff head accidentals dots) n
(format stream
- "[N :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)))
;;; Make a note with the pitch and staff given.
@@ -240,7 +251,7 @@
(defgeneric dots (element))
(defgeneric (setf dots) (dots element))
-(defclass element ()
+(defclass element (gsharp-object)
((bar :initform nil :initarg :bar :reader bar)
(notehead :initarg :notehead :accessor notehead)
(rbeams :initarg :rbeams :accessor rbeams)
@@ -248,6 +259,12 @@
(dots :initarg :dots :accessor dots)
(xoffset :initform 0 :initarg :xoffset :accessor xoffset)))
+(defmethod print-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 rbeams lbeams dots xoffset)))
+
(defmethod notehead-duration ((element element))
(ecase (notehead element)
(:whole 1)
@@ -290,15 +307,14 @@
(defgeneric remove-note (note))
(defclass cluster (melody-element)
- ((notes :initform '() :initarg :notes :accessor notes)
+ ((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)))
-(defmethod print-object ((c cluster) stream)
- (with-slots (notehead rbeams lbeams dots xoffset stem-direction notes) c
- (format stream
- "[% :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :stem-direction ~W :notes ~W ] "
- notehead rbeams lbeams dots xoffset stem-direction notes)))
+(defmethod print-object :after ((c cluster) stream)
+ (with-slots (stem-direction notes) c
+ (format stream ":stem-direction ~W :notes ~W " stem-direction notes)))
(defun make-cluster (rbeams lbeams dots notehead stem-direction)
(make-instance 'cluster
@@ -358,14 +374,13 @@
;;; Rest
(defclass rest (melody-element)
- ((staff :initarg :staff :reader staff)
+ ((print-character :allocation :class :initform #\-)
+ (staff :initarg :staff :reader staff)
(staff-pos :initarg :staff-pos :initform 4 :reader staff-pos)))
-(defmethod print-object ((s rest) stream)
- (with-slots (notehead rbeams lbeams dots xoffset staff staff-pos) s
- (format stream
- "[- :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :staff ~W :staff-pos ~W ] "
- notehead rbeams lbeams dots xoffset staff staff-pos)))
+(defmethod print-object :after ((s rest) stream)
+ (with-slots (staff staff-pos) s
+ (format stream ":staff ~W :staff-pos ~W " staff staff-pos)))
(defun make-rest (rbeams lbeams dots notehead staff)
(make-instance 'rest
@@ -403,7 +418,8 @@
;;; Lyrics element
(defclass lyrics-element (element)
- ((staff :initarg :staff :reader staff)
+ ((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)))
@@ -421,9 +437,9 @@
:rbeams rbeams :lbeams lbeams :dots dots
:notehead notehead :staff staff))
-(defmethod print-object ((elem lyrics-element) stream)
- (with-slots (notehead rbeams lbeams dots xoffset staff text) elem
- (format stream "[A :notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W :staff ~W :text ~W ] " notehead rbeams lbeams dots xoffset staff text)))
+(defmethod print-object :after ((elem lyrics-element) stream)
+ (with-slots (staff text) elem
+ (format stream ":staff ~W :text ~W " staff text)))
(defun read-lyrics-element-v3 (stream char n)
(declare (ignore char n))
@@ -467,10 +483,13 @@
;;; Delete an element from the bar to which it belongs.
(defgeneric remove-element (element))
-(defclass bar ()
+(defclass bar (gsharp-object)
((slice :initform nil :initarg :slice :reader slice)
(elements :initform '() :initarg :elements :reader elements)))
+(defmethod print-object :after ((b bar) stream)
+ (format stream ":elements ~W " (elements b)))
+
(defmethod nb-elements ((bar bar))
(length (elements bar)))
@@ -504,10 +523,8 @@
(setf elements (delete element elements :test #'eq)))
(setf bar nil)))
-(defclass melody-bar (bar) ())
-
-(defmethod print-object ((b melody-bar) stream)
- (format stream "[| :elements ~W ] " (elements b)))
+(defclass melody-bar (bar)
+ ((print-character :allocation :class :initform #\|)))
(defun make-melody-bar ()
(make-instance 'melody-bar))
@@ -537,10 +554,8 @@
#'read-melody-bar-v3
*gsharp-readtable-v3*)
-(defclass lyrics-bar (bar) ())
-
-(defmethod print-object ((b lyrics-bar) stream)
- (format stream "[C :elements ~W ] " (elements b)))
+(defclass lyrics-bar (bar)
+ ((print-character :allocation :class :initform #\C)))
(defun make-lyrics-bar ()
(make-instance 'lyrics-bar))
@@ -579,12 +594,13 @@
;;; Delete a bar from the slice to which it belongs.
(defgeneric remove-bar (bar))
-(defclass slice ()
- ((layer :initform nil :initarg :layer :reader layer)
+(defclass slice (gsharp-object)
+ ((print-character :allocation :class :initform #\/)
+ (layer :initform nil :initarg :layer :reader layer)
(bars :initform '() :initarg :bars :reader bars)))
-(defmethod print-object ((s slice) stream)
- (format stream "[/ :bars ~W ] " (bars s)))
+(defmethod print-object :after ((s slice) stream)
+ (format stream ":bars ~W " (bars s)))
(defun make-empty-slice ()
(make-instance 'slice))
@@ -688,17 +704,23 @@
;;; Return the tail slice of the layer
(defgeneric tail (layer))
-(defclass layer ()
- ((name :initform "default layer" :initarg :name :accessor name)
- (segment :initform nil :initarg :segment :reader segment)
+(defclass layer (gsharp-object name-mixin)
+ ((segment :initform nil :initarg :segment :reader segment)
(staves :initarg :staves :accessor staves)
(head :initarg :head :accessor head)
(body :initarg :body :accessor body)
- (tail :initarg :tail :accessor tail)))
+ (tail :initarg :tail :accessor tail))
+ (:default-initargs :name "default layer"))
+
+(defmethod print-object :after ((l layer) stream)
+ (with-slots (head body tail staves) l
+ (format stream ":staves ~W :head ~W :body ~W :tail ~W "
+ staves head body tail)))
;;; melody layer
-(defclass melody-layer (layer) ())
+(defclass melody-layer (layer)
+ ((print-character :allocation :class :initform #\_)))
(defmethod make-layer (name (initial-staff fiveline-staff))
(flet ((make-initialized-slice ()
@@ -716,11 +738,6 @@
(slot-value tail 'layer) result)
result)))
-(defmethod print-object ((l melody-layer) stream)
- (with-slots (head body tail name staves) l
- (format stream "[_ :name ~W :staves ~W :head ~W :body ~W :tail ~W ] "
- name staves head body tail)))
-
(defun read-melody-layer-v2 (stream char n)
(declare (ignore char n))
(let* ((staves (read stream nil nil t))
@@ -754,7 +771,8 @@
;;; lyrics layer
-(defclass lyrics-layer (layer) ())
+(defclass lyrics-layer (layer)
+ ((print-character :allocation :class :initform #\M)))
(defmethod make-layer (name (initial-staff lyrics-staff))
(flet ((make-initialized-slice ()
@@ -772,11 +790,6 @@
(slot-value tail 'layer) result)
result)))
-(defmethod print-object ((l lyrics-layer) stream)
- (with-slots (head body tail name staves) l
- (format stream "[M :name ~W :staves ~W :head ~W :body ~W :tail ~W ] "
- name staves head body tail)))
-
(defun read-lyrics-layer-v3 (stream char n)
(declare (ignore char n))
(let* ((rest (read-delimited-list #\] stream t))
@@ -860,12 +873,13 @@
;;; Delete a layer from the segment to which it belongs
(defgeneric remove-layer (layer))
-(defclass segment ()
- ((buffer :initform nil :initarg :buffer :reader buffer)
+(defclass segment (gsharp-object)
+ ((print-character :allocation :class :initform #\S)
+ (buffer :initform nil :initarg :buffer :reader buffer)
(layers :initform '() :initarg :layers :reader layers)))
-(defmethod print-object ((s segment) stream)
- (format stream "[S :layers ~W ] " (layers s)))
+(defmethod print-object :after ((s segment) stream)
+ (format stream ":layers ~W " (layers s)))
(defun make-empty-segment ()
(make-instance 'segment))
@@ -974,8 +988,9 @@
(defvar *default-left-offset* 30)
(defvar *default-left-margin* 20)
-(defclass buffer ()
- ((segments :initform '() :initarg :segments :accessor segments)
+(defclass buffer (gsharp-object)
+ ((print-character :allocation :class :initform #\B)
+ (segments :initform '() :initarg :segments :accessor segments)
(staves :initform (list (make-fiveline-staff "default staff"))
:initarg :staves :accessor staves)
(min-width :initform *default-min-width* :initarg :min-width :accessor min-width)
@@ -984,9 +999,9 @@
(left-offset :initform *default-left-offset* :initarg :left-offset :accessor left-offset)
(left-margin :initform *default-left-margin* :initarg :left-margin :accessor left-margin)))
-(defmethod print-object ((b buffer) stream)
+(defmethod print-object :after ((b buffer) stream)
(with-slots (staves segments min-width spacing-style right-edge left-offset left-margin) b
- (format stream "[B :staves ~W :segments ~W :min-width ~W :spacing-style ~W :right-edge ~W :left-offset ~W :left-margin ~W ] "
+ (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)))
(defun make-empty-buffer ()
