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