]> git.donarmstrong.com Git - lilypond.git/blob - scm/parser-clef.scm
c92de614c7da0a23fd370eb7ed4a00170c49bcb2
[lilypond.git] / scm / parser-clef.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2004--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
4 ;;;;
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
9 ;;;;
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
17
18
19 ;; (name . (glyph clef-position octavation))
20 ;;
21 ;; -- the name clefOctavation is misleading. The value 7 is 1 octave,
22 ;; not 7 Octaves.
23 (define-public supported-clefs
24   '(("treble" . ("clefs.G" -2 0))
25     ("violin" . ("clefs.G" -2 0))
26     ("G" . ("clefs.G" -2 0))
27     ("G2" . ("clefs.G" -2 0))
28     ("french" . ("clefs.G" -4 0))
29     ("soprano" . ("clefs.C" -4 0))
30     ("mezzosoprano" . ("clefs.C" -2 0))
31     ("alto" . ("clefs.C" 0 0))
32     ("C" . ("clefs.C" 0 0))
33     ("tenor" . ("clefs.C" 2 0))
34     ("baritone" . ("clefs.C" 4 0))
35     ("varbaritone" . ("clefs.F" 0 0))
36     ("bass" . ("clefs.F" 2 0))
37     ("F" . ("clefs.F" 2 0))
38     ("subbass" . ("clefs.F" 4 0))
39     ("percussion" . ("clefs.percussion" 0 0))
40     ("tab" . ("clefs.tab" 0 0))
41
42     ;; should move mensural stuff to separate file?
43     ("vaticana-do1" . ("clefs.vaticana.do" -1 0))
44     ("vaticana-do2" . ("clefs.vaticana.do" 1 0))
45     ("vaticana-do3" . ("clefs.vaticana.do" 3 0))
46     ("vaticana-fa1" . ("clefs.vaticana.fa" -1 0))
47
48     ("vaticana-fa2" . ("clefs.vaticana.fa" 1 0))
49     ("medicaea-do1" . ("clefs.medicaea.do" -1 0))
50     ("medicaea-do2" . ("clefs.medicaea.do" 1 0))
51     ("medicaea-do3" . ("clefs.medicaea.do" 3 0))
52     ("medicaea-fa1" . ("clefs.medicaea.fa" -1 0))
53     ("medicaea-fa2" . ("clefs.medicaea.fa" 1 0))
54     ("hufnagel-do1" . ("clefs.hufnagel.do" -1 0))
55     ("hufnagel-do2" . ("clefs.hufnagel.do" 1 0))
56     ("hufnagel-do3" . ("clefs.hufnagel.do" 3 0))
57     ("hufnagel-fa1" . ("clefs.hufnagel.fa" -1 0))
58     ("hufnagel-fa2" . ("clefs.hufnagel.fa" 1 0))
59     ("hufnagel-do-fa" . ("clefs.hufnagel.do.fa" 4 0))
60     ("mensural-c1" . ("clefs.mensural.c" -2 0))
61     ("mensural-c2" . ("clefs.mensural.c" 0 0))
62     ("mensural-c3" . ("clefs.mensural.c" 2 0))
63     ("mensural-c4" . ("clefs.mensural.c" 4 0))
64     ("mensural-f" . ("clefs.mensural.f" 2 0))
65     ("mensural-g" . ("clefs.mensural.g" -2 0))
66     ("neomensural-c1" . ("clefs.neomensural.c" -4 0))
67     ("neomensural-c2" . ("clefs.neomensural.c" -2 0))
68     ("neomensural-c3" . ("clefs.neomensural.c" 0 0))
69     ("neomensural-c4" . ("clefs.neomensural.c" 2 0))
70     ("petrucci-c1" . ("clefs.petrucci.c1" -4 0))
71     ("petrucci-c2" . ("clefs.petrucci.c2" -2 0))
72     ("petrucci-c3" . ("clefs.petrucci.c3" 0 0))
73     ("petrucci-c4" . ("clefs.petrucci.c4" 2 0))
74     ("petrucci-c5" . ("clefs.petrucci.c5" 4 0))
75     ("petrucci-f3" . ("clefs.petrucci.f" 0 0))
76     ("petrucci-f4" . ("clefs.petrucci.f" 2 0))
77     ("petrucci-f5" . ("clefs.petrucci.f" 4 0))
78     ("petrucci-f" . ("clefs.petrucci.f" 2 0))
79     ("petrucci-g" . ("clefs.petrucci.g" -2 0))))
80
81 ;; "an alist mapping GLYPHNAME to the position of the middle C for
82 ;; that symbol"
83 (define c0-pitch-alist
84   '(("clefs.G" . -4)
85     ("clefs.C" . 0)
86     ("clefs.F" . 4)
87     ("clefs.percussion" . 0)
88     ("clefs.tab" . 0 )
89     ("clefs.vaticana.do" . 0)
90     ("clefs.vaticana.fa" . 4)
91     ("clefs.medicaea.do" . 0)
92     ("clefs.medicaea.fa" . 4)
93     ("clefs.hufnagel.do" . 0)
94     ("clefs.hufnagel.fa" . 4)
95     ("clefs.hufnagel.do.fa" . 0)
96     ("clefs.mensural.c" . 0)
97     ("clefs.mensural.f" . 4)
98     ("clefs.mensural.g" . -4)
99     ("clefs.neomensural.c" . 0)
100     ("clefs.petrucci.c1" . 0)
101     ("clefs.petrucci.c2" . 0)
102     ("clefs.petrucci.c3" . 0)
103     ("clefs.petrucci.c4" . 0)
104     ("clefs.petrucci.c5" . 0)
105     ("clefs.petrucci.f" . 4)
106     ("clefs.petrucci.g" . -4)))
107
108 (define-public (make-clef-set clef-name)
109   "Generate the clef setting commands for a clef with name @var{clef-name}."
110   (define (make-prop-set props)
111     (let ((m (make-music 'PropertySet)))
112       (map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props)
113       m))
114   (let ((e '())
115         (c0 0)
116         (oct 0)
117         (match (string-match "^(.*)([_^])([1-9][0-9]*)$" clef-name)))
118     (if match
119         (begin
120           (set! clef-name (match:substring match 1))
121           (set! oct
122                 (* (if (equal? (match:substring match 2) "^") -1 1)
123                    (- (string->number (match:substring match 3)) 1)))))
124     (set! e (assoc-get clef-name supported-clefs))
125     (if e
126         (let* ((musics (map make-prop-set
127                             `(((symbol . clefGlyph) (value . ,(car e)))
128                               ((symbol . middleCClefPosition)
129                                (value . ,(+ oct
130                                             (cadr e)
131                                             (assoc-get (car e) c0-pitch-alist))))
132                               ((symbol . clefPosition) (value . ,(cadr e)))
133                               ((symbol . clefOctavation) (value . ,(- oct))))))
134                (recalc-mid-C (make-music 'ApplyContext))
135                (seq (make-music 'SequentialMusic
136                                 'elements (append musics (list recalc-mid-C))))
137                (csp (make-music 'ContextSpeccedMusic)))
138           (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!)
139           (context-spec-music seq 'Staff))
140         (begin
141           (ly:warning (_ "unknown clef type `~a'") clef-name)
142           (ly:warning (_ "supported clefs: ~a")
143                       (string-join
144                        (sort (map car supported-clefs) string<?)))
145           (make-music 'Music)))))
146
147 (define-public (make-cue-clef-set clef-name)
148   "Generate the clef setting commands for a cue clef with name
149 @var{clef-name}."
150   (define (make-prop-set props)
151     (let ((m (make-music 'PropertySet)))
152       (map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props)
153       m))
154   (let ((e '())
155         (c0 0)
156         (oct 0)
157         (match (string-match "^(.*)([_^])([1-9][0-9]*)$" clef-name)))
158     (if match
159         (begin
160           (set! clef-name (match:substring match 1))
161           (set! oct
162                 (* (if (equal? (match:substring match 2) "^") -1 1)
163                    (- (string->number (match:substring match 3)) 1)))))
164     (set! e (assoc-get clef-name supported-clefs))
165     (if e
166         (let* ((musics (map make-prop-set
167                             `(((symbol . cueClefGlyph) (value . ,(car e)))
168                               ((symbol . middleCCuePosition)
169                                (value . ,(+ oct
170                                             (cadr e)
171                                             (assoc-get (car e) c0-pitch-alist))))
172                               ((symbol . cueClefPosition) (value . ,(cadr e)))
173                               ((symbol . cueClefOctavation) (value . ,(- oct))))))
174                (recalc-mid-C (make-music 'ApplyContext))
175                (seq (make-music 'SequentialMusic
176                                 'elements (append musics (list recalc-mid-C))))
177                (csp (make-music 'ContextSpeccedMusic)))
178           (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!)
179           (context-spec-music seq 'Staff))
180         (begin
181           (ly:warning (_ "unknown clef type `~a'") clef-name)
182           (ly:warning (_ "supported clefs: ~a")
183                       (string-join
184                        (sort (map car supported-clefs) string<?)))
185           (make-music 'Music)))))
186
187
188 (define-public (make-cue-clef-unset)
189   "Reset the clef settings for a cue clef."
190   (define (make-prop-unset props)
191     (let ((m (make-music 'PropertyUnset)))
192       (set! (ly:music-property m (car props)) (cdr props))
193       m))
194   (let* ((musics (map make-prop-unset
195                         `((symbol . cueClefGlyph)
196                           (symbol . middleCCuePosition)
197                           (symbol . cueClefPosition)
198                           (symbol . cueClefOctavation))))
199          (recalc-mid-C (make-music 'ApplyContext))
200          (seq (make-music 'SequentialMusic
201                           'elements (append musics (list recalc-mid-C))))
202          (csp (make-music 'ContextSpeccedMusic)))
203     (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!)
204     (context-spec-music seq 'Staff)))
205
206
207 ;; a function to add new clefs at runtime
208 (define-public (add-new-clef clef-name clef-glyph clef-position octavation c0-position)
209   "Append the entries for a clef symbol to supported clefs and
210 @code{c0-pitch-alist}."
211   (set! supported-clefs
212         (acons clef-name (list clef-glyph clef-position octavation) supported-clefs))
213   (set! c0-pitch-alist
214         (acons clef-glyph c0-position c0-pitch-alist)))