]> git.donarmstrong.com Git - lilypond.git/blob - lily/music.cc
3dbbe123e522067d8aee92a31c0b872fffdcb84e
[lilypond.git] / lily / music.cc
1 /*
2   music.cc -- implement Music
3
4   source file of the GNU LilyPond music typesetter
5
6   (c) 1997--2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
7 */
8
9 #include "music.hh"
10
11 #include "context.hh"
12 #include "dispatcher.hh"
13 #include "duration.hh"
14 #include "input.hh"
15 #include "international.hh"
16 #include "ly-smobs.icc"
17 #include "main.hh"
18 #include "music-sequence.hh"
19 #include "score.hh"
20 #include "warn.hh"
21
22 /*
23   Music is anything that has (possibly zero) duration and supports
24   both time compression and transposition.
25
26   In Lily, everything that can be thought to have a length and a pitch
27   (which has a duration which can be transposed) is considered "music".
28 */
29 bool
30 Music::internal_is_music_type (SCM k) const
31 {
32   SCM ifs = get_property ("types");
33
34   return scm_c_memq (k, ifs) != SCM_BOOL_F;
35 }
36
37 Music::Music (SCM init)
38   : Prob (ly_symbol2scm ("Music"), init)
39 {
40   length_callback_ = SCM_EOL;
41   start_callback_ = SCM_EOL;
42   
43   length_callback_ = get_property ("length-callback");
44   if (!ly_is_procedure (length_callback_))
45     length_callback_ = duration_length_callback_proc;
46
47   start_callback_ = get_property ("start-callback");
48 }
49
50 void
51 Music::derived_mark () const
52 {
53   scm_gc_mark (length_callback_);
54   scm_gc_mark (start_callback_);
55 }
56
57 SCM
58 Music::copy_mutable_properties () const
59 {
60   return ly_music_deep_copy (mutable_property_alist_);
61 }
62
63 void
64 Music::type_check_assignment (SCM s, SCM v) const
65 {
66   if (!::type_check_assignment (s, v, ly_symbol2scm ("music-type?")))
67     abort ();
68 }
69
70 Music::Music (Music const &m)
71   : Prob (m)
72 {
73   length_callback_ = m.length_callback_;
74   start_callback_ = m.start_callback_;
75
76   /// why? 
77   set_spot (*m.origin ());
78 }
79
80 Moment
81 Music::get_length () const
82 {
83   SCM lst = get_property ("length");
84   if (unsmob_moment (lst))
85     return *unsmob_moment (lst);
86
87   if (ly_is_procedure (length_callback_))
88     {
89       SCM res = scm_call_1 (length_callback_, self_scm ());
90       return *unsmob_moment (res);
91     }
92
93   return Moment (0);
94 }
95
96 Moment
97 Music::start_mom () const
98 {
99   SCM lst = start_callback_;
100   if (ly_is_procedure (lst))
101     {
102       SCM res = scm_call_1 (lst, self_scm ());
103       return *unsmob_moment (res);
104     }
105
106   Moment m;
107   return m;
108 }
109
110 void
111 print_alist (SCM a, SCM port)
112 {
113   /* SCM_EOL  -> catch malformed lists.  */
114   for (SCM s = a; scm_is_pair (s); s = scm_cdr (s))
115     {
116       scm_display (scm_caar (s), port);
117       scm_puts (" = ", port);
118       scm_write (scm_cdar (s), port);
119       scm_puts ("\n", port);
120     }
121 }
122
123
124 Pitch
125 Music::generic_to_relative_octave (Pitch last)
126 {
127   SCM elt = get_property ("element");
128   Pitch *old_pit = unsmob_pitch (get_property ("pitch"));
129   if (old_pit)
130     {
131       Pitch new_pit = *old_pit;
132       new_pit = new_pit.to_relative_octave (last);
133
134       SCM check = get_property ("absolute-octave");
135       if (scm_is_number (check)
136           && new_pit.get_octave () != scm_to_int (check))
137         {
138           Pitch expected_pit (scm_to_int (check),
139                               new_pit.get_notename (),
140                               new_pit.get_alteration ());
141           origin ()->warning (_f ("octave check failed; expected \"%s\", found: \"%s\"",
142                                   expected_pit.to_string (),
143                                   new_pit.to_string ()));
144           new_pit = expected_pit;
145         }
146
147       set_property ("pitch", new_pit.smobbed_copy ());
148
149       last = new_pit;
150     }
151
152   if (Music *m = unsmob_music (elt))
153     last = m->to_relative_octave (last);
154
155   last = music_list_to_relative (get_property ("elements"), last, false);
156   return last;
157 }
158
159 Pitch
160 Music::to_relative_octave (Pitch last)
161 {
162   SCM callback = get_property ("to-relative-callback");
163   if (ly_is_procedure (callback))
164     {
165       Pitch *p = unsmob_pitch (scm_call_2 (callback, self_scm (), last.smobbed_copy ()));
166       return *p;
167     }
168
169   return generic_to_relative_octave (last);
170 }
171
172 void
173 Music::compress (Moment factor)
174 {
175   SCM elt = get_property ("element");
176
177   if (Music *m = unsmob_music (elt))
178     m->compress (factor);
179
180   compress_music_list (get_property ("elements"), factor);
181   Duration *d = unsmob_duration (get_property ("duration"));
182   if (d)
183     set_property ("duration", d->compressed (factor.main_part_).smobbed_copy ());
184 }
185
186 /*
187   This mutates alist.  Hence, make sure that it is not shared 
188 */
189 void
190 transpose_mutable (SCM alist, Pitch delta)
191 {
192   for (SCM s = alist; scm_is_pair (s); s = scm_cdr (s))
193     {
194       SCM entry = scm_car (s);
195       SCM prop = scm_car (entry);
196       SCM val = scm_cdr (entry);
197       SCM new_val = val;
198       
199       if (Pitch *p = unsmob_pitch (val))
200         {
201           Pitch transposed = p->transposed (delta);
202           if (transposed.get_alteration ().abs () > Rational (1,1))
203             {
204               warning (_f ("transposition by %s makes alteration larger than double",
205                            delta.to_string ()));
206             }
207
208           new_val = transposed.smobbed_copy ();
209         }
210       else if (prop == ly_symbol2scm ("element"))
211         {
212           if (Music *m = unsmob_music (val))
213             m->transpose (delta);
214         }
215       else if (prop == ly_symbol2scm ("elements"))
216         transpose_music_list (val, delta);
217       else if (prop == ly_symbol2scm ("pitch-alist") &&
218                scm_is_pair (val))
219         new_val = ly_transpose_key_alist (val, delta.smobbed_copy ());
220
221       if (val != new_val)
222         scm_set_cdr_x (entry , new_val);
223     }
224 }
225
226 void
227 Music::transpose (Pitch delta)
228 {
229   if (to_boolean (get_property ("untransposable")))
230     return;
231
232   transpose_mutable (mutable_property_alist_, delta);
233 }
234
235 void
236 Music::set_spot (Input ip)
237 {
238   set_property ("origin", make_input (ip));
239 }
240
241 Input *
242 Music::origin () const
243 {
244   Input *ip = unsmob_input (get_property ("origin"));
245   return ip ? ip : &dummy_input_global;
246 }
247
248 /*
249   ES TODO: This method should probably be reworked or junked.
250 */
251 Stream_event *
252 Music::to_event () const
253 {
254   SCM class_name = ly_camel_case_to_lisp_identifier (get_property ("name"));
255
256   // catch programming mistakes.
257   if (!internal_is_music_type (class_name))
258     {
259       programming_error ("Not a music type");
260     }
261
262   Stream_event *e = new Stream_event (class_name, mutable_property_alist_);
263   Moment length = get_length ();
264   if (length.to_bool ())
265     e->set_property ("length", length.smobbed_copy ());
266
267   // articulations as events.
268   SCM art_mus = e->get_property ("articulations");
269   if (scm_is_pair (art_mus))
270     {
271       SCM art_ev = SCM_EOL;
272       for (; scm_is_pair (art_mus); art_mus = scm_cdr (art_mus))
273         {
274           Music *m = unsmob_music (scm_car (art_mus));
275           SCM ev = m ? m->to_event ()->unprotect () : scm_car (art_mus);
276           art_ev = scm_cons (ev, art_ev);
277         }
278       e->set_property ("articulations", scm_reverse_x (art_ev, SCM_EOL));
279     }
280
281   /*
282     ES TODO: This is a temporary fix. Stream_events should not be
283     aware of music.
284   */
285   e->set_property ("music-cause", self_scm ());
286
287   return e;
288 }
289
290 void
291 Music::send_to_context (Context *c)
292 {
293   Stream_event *ev = to_event ();
294   c->event_source ()->broadcast (ev);
295   ev->unprotect ();
296 }
297
298 Music *
299 make_music_by_name (SCM sym)
300 {
301   SCM make_music_proc = ly_lily_module_constant ("make-music");
302   SCM rv = scm_call_1 (make_music_proc, sym);
303
304   /* UGH. */
305   Music *m = unsmob_music (rv);
306   m->protect ();
307   return m;
308 }
309
310 MAKE_SCHEME_CALLBACK (Music, duration_length_callback, 1);
311 SCM
312 Music::duration_length_callback (SCM m)
313 {
314   Music *me = unsmob_music (m);
315   Duration *d = unsmob_duration (me->get_property ("duration"));
316
317   Moment mom;
318   if (d)
319     mom = d->get_length ();
320   return mom.smobbed_copy ();
321 }
322
323 Music *
324 unsmob_music (SCM m)
325 {
326   return dynamic_cast<Music*> (unsmob_prob (m));
327 }
328