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 "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 /*
 188 TODO: make transposition non-destructive
 189 */
 190 SCM
 191 transpose_mutable (SCM alist, Pitch delta)
 192 {
 193   SCM retval = SCM_EOL;
 194
 195   for (SCM s = alist; scm_is_pair (s); s = scm_cdr (s))
 196     {
 197       SCM entry = scm_car (s);
 198       SCM prop = scm_car (entry);
 199       SCM val = scm_cdr (entry);
 200
 201       if (Pitch *p = unsmob_pitch (val))
 202         {
 203           Pitch transposed = p->transposed (delta);
 204           scm_set_cdr_x (entry, transposed.smobbed_copy ());
 205
 206           if (abs (transposed.get_alteration ()) > DOUBLE_SHARP)
 207             {
 208               warning (_f ("transposition by %s makes alteration larger than double",
 209                            delta.to_string ()));
 210             }
 211         }
 212       else if (prop == ly_symbol2scm ("element"))
 213         {
 214           if (Music *m = unsmob_music (val))
 215             m->transpose (delta);
 216         }
 217       else if (prop == ly_symbol2scm ("elements"))
 218         transpose_music_list (val, delta);
 219       else if (prop == ly_symbol2scm ("pitch-alist") &&
 220                scm_is_pair (val))
 221         entry = scm_cons (prop, ly_transpose_key_alist (val, delta.smobbed_copy ()));
 222       retval = scm_cons (entry, retval);
 223     }
 224
 225   return scm_reverse_x (retval, SCM_EOL);
 226 }
 227
 228 void
 229 Music::transpose (Pitch delta)
 230 {
 231   if (to_boolean (get_property ("untransposable")))
 232     return;
 233
 234   mutable_property_alist_ = transpose_mutable (mutable_property_alist_, delta);
 235 }
 236
 237 void
 238 Music::set_spot (Input ip)
 239 {
 240   set_property ("origin", make_input (ip));
 241 }
 242
 243 Input *
 244 Music::origin () const
 245 {
 246   Input *ip = unsmob_input (get_property ("origin"));
 247   return ip ? ip : &dummy_input_global;
 248 }
 249
 250 /*
 251   ES TODO: This method should probably be reworked or junked.
 252 */
 253 Stream_event *
 254 Music::to_event () const
 255 {
 256   /* UGH. Temp hack */
 257   SCM orig_sym = get_property ("name");
 258   char out[200];
 259   string in = ly_symbol2string (orig_sym);
 260   /* don't add '-' before first character */
 261   out[0] = tolower (in[0]);
 262   size_t outpos = 1;
 263   for (size_t inpos = 1; inpos < in.size () && outpos < 190; inpos++)
 264     {
 265       if (isupper (in[inpos]))
 266         out[outpos++] = '-';
 267       out[outpos++] = tolower (in[inpos]);
 268     }
 269   out[outpos] = 0;
 270   SCM class_name = ly_symbol2scm (out);
 271
 272   // catch programming mistakes.
 273   if (!internal_is_music_type (class_name))
 274     {
 275       programming_error ("Not a music type");
 276     }
 277
 278   Stream_event *e = new Stream_event (class_name, mutable_property_alist_);
 279   Moment length = get_length ();
 280   if (length.to_bool ())
 281     e->set_property ("length", length.smobbed_copy ());
 282
 283   // articulations as events.
 284   SCM art_mus = e->get_property ("articulations");
 285   if (scm_is_pair (art_mus))
 286     {
 287       SCM art_ev = SCM_EOL;
 288       for (; scm_is_pair (art_mus); art_mus = scm_cdr (art_mus))
 289         {
 290           Music *m = unsmob_music (scm_car (art_mus));
 291           SCM ev = m ? m->to_event ()->unprotect () : scm_car (art_mus);
 292           art_ev = scm_cons (ev, art_ev);
 293         }
 294       e->set_property ("articulations", scm_reverse_x (art_ev, SCM_EOL));
 295     }
 296
 297   /*
 298     ES TODO: This is a temporary fix. Stream_events should not be
 299     aware of music.
 300   */
 301   e->set_property ("music-cause", self_scm ());
 302
 303   return e;
 304 }
 305
 306 void
 307 Music::send_to_context (Context *c)
 308 {
 309   Stream_event *ev = to_event ();
 310   c->event_source ()->broadcast (ev);
 311   ev->unprotect ();
 312 }
 313
 314 Music *
 315 make_music_by_name (SCM sym)
 316 {
 317   SCM make_music_proc = ly_lily_module_constant ("make-music");
 318   SCM rv = scm_call_1 (make_music_proc, sym);
 319
 320   /* UGH. */
 321   Music *m = unsmob_music (rv);
 322   m->protect ();
 323   return m;
 324 }
 325
 326 MAKE_SCHEME_CALLBACK (Music, duration_length_callback, 1);
 327 SCM
 328 Music::duration_length_callback (SCM m)
 329 {
 330   Music *me = unsmob_music (m);
 331   Duration *d = unsmob_duration (me->get_property ("duration"));
 332
 333   Moment mom;
 334   if (d)
 335     mom = d->get_length ();
 336   return mom.smobbed_copy ();
 337 }
 338
 339 Music *
 340 unsmob_music (SCM m)
 341 {
 342   return dynamic_cast<Music*> (unsmob_prob (m));
 343 }
 344