/[gsharp]/gsharp/lyrics.lisp
ViewVC logotype

Contents of /gsharp/lyrics.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Oct 22 10:03:40 2007 UTC (6 years, 6 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +4 -8 lines
Got rid of the print-character slot which was used in the old I/O
mechanism.
1 (in-package :gsharp-buffer)
2
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;;;
5 ;;; staff
6
7 (defclass lyrics-staff (staff) ())
8
9 (defun make-lyrics-staff (&rest args &key name)
10 (declare (ignore name))
11 (apply #'make-instance 'lyrics-staff args))
12
13 (defun read-lyrics-staff-v3 (stream char n)
14 (declare (ignore char n))
15 (apply #'make-instance 'lyrics-staff (read-delimited-list #\] stream t)))
16
17 (set-dispatch-macro-character #\[ #\L
18 #'read-lyrics-staff-v3
19 *gsharp-readtable-v3*)
20
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 ;;;
23 ;;; Lyrics element
24
25 (defclass lyrics-element (rhythmic-element)
26 ((staff :initarg :staff :reader staff)
27 (text :initarg :text
28 :initform (make-array 5 :adjustable t :element-type 'fixnum :fill-pointer 0)
29 :reader text)
30 (%tie-right :initform nil :initarg :tie-right :accessor tie-right)
31 (%tie-left :initform nil :initarg :tie-left :accessor tie-left)))
32
33 (defmethod initialize-instance :after ((elem lyrics-element) &rest args)
34 (declare (ignore args))
35 (with-slots (text) elem
36 (unless (adjustable-array-p text)
37 (let ((length (length text)))
38 (setf text (make-array length :adjustable t :element-type 'fixnum
39 :fill-pointer length :initial-contents text))))))
40
41 (defun make-lyrics-element (staff &rest args
42 &key (notehead :filled) (lbeams 0) (rbeams 0)
43 (dots 0) (xoffset 0))
44 (declare (type staff staff)
45 (type (member :long :breve :whole :half :filled) notehead)
46 (type (integer 0 5) lbeams)
47 (type (integer 0 5) rbeams)
48 (type (integer 0 3) dots)
49 (type number xoffset)
50 (ignore notehead lbeams rbeams dots xoffset))
51 (apply #'make-instance 'lyrics-element
52 :staff staff args))
53
54 (defmethod slots-to-be-saved append ((elem lyrics-element))
55 '(staff text))
56
57 (defun read-lyrics-element-v3 (stream char n)
58 (declare (ignore char n))
59 (apply #'make-instance 'lyrics-element (read-delimited-list #\] stream t)))
60
61 (set-dispatch-macro-character #\[ #\A
62 #'read-lyrics-element-v3
63 *gsharp-readtable-v3*)
64
65 (defmethod append-char ((elem lyrics-element) char)
66 (vector-push-extend char (text elem)))
67
68 (defmethod erase-char ((elem lyrics-element))
69 (unless (zerop (fill-pointer (text elem)))
70 (decf (fill-pointer (text elem)))))
71
72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
73 ;;;
74 ;;; Lyrics bar
75
76 (defclass lyrics-bar (bar) ())
77
78 (defun make-lyrics-bar (&rest args &key elements)
79 (declare (type list elements)
80 (ignore elements))
81 (apply #'make-instance 'lyrics-bar args))
82
83 (defmethod make-bar-for-staff ((staff lyrics-staff) &rest args &key elements)
84 (declare (ignore elements))
85 (apply #'make-instance 'lyrics-bar args))
86
87 (defun read-lyrics-bar-v3 (stream char n)
88 (declare (ignore char n))
89 (apply #'make-instance 'lyrics-bar (read-delimited-list #\] stream t)))
90
91 (set-dispatch-macro-character #\[ #\C
92 #'read-lyrics-bar-v3
93 *gsharp-readtable-v3*)
94
95 (defmethod remove-bar ((bar lyrics-bar))
96 (with-slots (slice) bar
97 (assert slice () 'bar-not-in-slice)
98 (with-slots (bars) slice
99 (setf bars (delete bar bars :test #'eq))
100 (unless bars
101 ;; make sure there is one bar left
102 (add-bar (make-lyrics-bar) slice 0)))
103 (setf slice nil)))
104
105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
106 ;;;
107 ;;; Lyrics layer
108
109 (defclass lyrics-layer (layer) ())
110
111 (defun read-lyrics-layer-v3 (stream char n)
112 (declare (ignore char n))
113 (apply #'make-instance 'lyrics-layer (read-delimited-list #\] stream t)))
114
115 (set-dispatch-macro-character #\[ #\M
116 #'read-lyrics-layer-v3
117 *gsharp-readtable-v3*)
118
119 (defmethod make-layer-for-staff ((staff lyrics-staff) &rest args &key staves head body tail &allow-other-keys)
120 (declare (ignore staves head body tail))
121 (apply #'make-instance 'lyrics-layer args))
122

  ViewVC Help
Powered by ViewVC 1.1.5