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 #include "music-sequence.hh"
  11 #include "duration.hh"
  12 #include "input-smob.hh"
  13 #include "ly-smobs.icc"
  14 #include "main.hh"
  15 #include "pitch.hh"
  16 #include "score.hh"
  17 #include "warn.hh"
  18
  19 /*
  20   Music is anything that has duration and supports both time compression
  21   and transposition.
  22
  23   In Lily, everything that can be thought to have a length and a pitch
  24   (which has a duration which can be transposed) is considered "music",
  25 */
  26 bool
  27 Music::internal_is_music_type (SCM k) const
  28 {
  29   SCM ifs = get_property ("types");
  30
  31   return scm_c_memq (k, ifs) != SCM_BOOL_F;
  32 }
  33
  34 Music::Music (SCM init)
  35   : Prob (ly_symbol2scm ("Music"), init)
  36 {
  37   length_callback_ = SCM_EOL;
  38   start_callback_ = SCM_EOL;
  39
  40   length_callback_ = get_property ("length-callback");
  41   if (!ly_is_procedure (length_callback_))
  42     length_callback_ = duration_length_callback_proc;
  43
  44   start_callback_ = get_property ("start-callback");
  45 }
  46
  47 void
  48 Music::derived_mark () const
  49 {
  50   scm_gc_mark (length_callback_);
  51   scm_gc_mark (start_callback_);
  52 }
  53
  54 SCM
  55 Music::copy_mutable_properties () const
  56 {
  57   return ly_music_deep_copy (mutable_property_alist_);
  58 }
  59
  60 void
  61 Music::type_check_assignment (SCM s, SCM v) const
  62 {
  63   if (!::type_check_assignment (s, v, ly_symbol2scm ("music-type?")))
  64     abort ();
  65 }
  66
  67 Music::Music (Music const &m)
  68   : Prob (m)
  69 {
  70   length_callback_ = m.length_callback_;
  71   start_callback_ = m.start_callback_;
  72
  73   /// why?
  74   set_spot (*m.origin ());
  75 }
  76
  77 Moment
  78 Music::get_length () const
  79 {
  80   SCM lst = get_property ("length");
  81   if (unsmob_moment (lst))
  82     return *unsmob_moment (lst);
  83
  84   if (ly_is_procedure (length_callback_))
  85     {
  86       SCM res = scm_call_1 (length_callback_, self_scm ());
  87       return *unsmob_moment (res);
  88     }
  89
  90   return Moment (0);
  91 }
  92
  93 Moment
  94 Music::start_mom () const
  95 {
  96   SCM lst = start_callback_;
  97   if (ly_is_procedure (lst))
  98     {
  99       SCM res = scm_call_1 (lst, self_scm ());
 100       return *unsmob_moment (res);
 101     }
 102
 103   Moment m;
 104   return m;
 105 }
 106
 107 void
 108 print_alist (SCM a, SCM port)
 109 {
 110   /* SCM_EOL  -> catch malformed lists.  */
 111   for (SCM s = a; scm_is_pair (s); s = scm_cdr (s))
 112     {
 113       scm_display (scm_caar (s), port);
 114       scm_puts (" = ", port);
 115       scm_write (scm_cdar (s), port);
 116       scm_puts ("\n", port);
 117     }
 118 }
 119
 120
 121 Pitch
 122 Music::generic_to_relative_octave (Pitch last)
 123 {
 124   SCM elt = get_property ("element");
 125   Pitch *old_pit = unsmob_pitch (get_property ("pitch"));
 126   if (old_pit)
 127     {
 128       Pitch new_pit = *old_pit;
 129       new_pit = new_pit.to_relative_octave (last);
 130
 131       SCM check = get_property ("absolute-octave");
 132       if (scm_is_number (check)
 133           && new_pit.get_octave () != scm_to_int (check))
 134         {
 135           Pitch expected_pit (scm_to_int (check),
 136                               new_pit.get_notename (),
 137                               new_pit.get_alteration ());
 138           origin ()->warning (_f ("octave check failed; expected %s, found: %s",
 139                                   expected_pit.to_string (),
 140                                   new_pit.to_string ()));
 141           new_pit = expected_pit;
 142         }
 143
 144       set_property ("pitch", new_pit.smobbed_copy ());
 145
 146       last = new_pit;
 147     }
 148
 149   if (Music *m = unsmob_music (elt))
 150     last = m->to_relative_octave (last);
 151
 152   last = music_list_to_relative (get_property ("elements"), last, false);
 153   return last;
 154 }
 155
 156 Pitch
 157 Music::to_relative_octave (Pitch last)
 158 {
 159   SCM callback = get_property ("to-relative-callback");
 160   if (ly_is_procedure (callback))
 161     {
 162       Pitch *p = unsmob_pitch (scm_call_2 (callback, self_scm (), last.smobbed_copy ()));
 163       return *p;
 164     }
 165
 166   return generic_to_relative_octave (last);
 167 }
 168
 169 void
 170 Music::compress (Moment factor)
 171 {
 172   SCM elt = get_property ("element");
 173
 174   if (Music *m = unsmob_music (elt))
 175     m->compress (factor);
 176
 177   compress_music_list (get_property ("elements"), factor);
 178   Duration *d = unsmob_duration (get_property ("duration"));
 179   if (d)
 180     set_property ("duration", d->compressed (factor.main_part_).smobbed_copy ());
 181 }
 182
 183 void
 184 Music::transpose (Pitch delta)
 185 {
 186   if (to_boolean (get_property ("untransposable")))
 187     return;
 188
 189   for (SCM s = this->get_property_alist (true); scm_is_pair (s); s = scm_cdr (s))
 190     {
 191       SCM entry = scm_car (s);
 192       SCM val = scm_cdr (entry);
 193
 194       if (Pitch *p = unsmob_pitch (val))
 195         {
 196           Pitch transposed = p->transposed (delta);
 197           scm_set_cdr_x (entry, transposed.smobbed_copy ());
 198
 199           if (abs (transposed.get_alteration ()) > DOUBLE_SHARP)
 200             {
 201               warning (_f ("transposition by %s makes alteration larger than double",
 202                            delta.to_string ()));
 203             }
 204         }
 205     }
 206
 207   SCM elt = get_property ("element");
 208
 209   if (Music *m = unsmob_music (elt))
 210     m->transpose (delta);
 211
 212   transpose_music_list (get_property ("elements"), delta);
 213
 214   /*
 215     UGH - how do this more generically?
 216   */
 217   SCM pa = get_property ("pitch-alist");
 218   if (scm_is_pair (pa))
 219     set_property ("pitch-alist", ly_transpose_key_alist (pa, delta.smobbed_copy ()));
 220 }
 221
 222 void
 223 Music::set_spot (Input ip)
 224 {
 225   set_property ("origin", make_input (ip));
 226 }
 227
 228 Input *
 229 Music::origin () const
 230 {
 231   Input *ip = unsmob_input (get_property ("origin"));
 232   return ip ? ip : &dummy_input_global;
 233 }
 234
 235 Music *
 236 make_music_by_name (SCM sym)
 237 {
 238   SCM make_music_proc = ly_lily_module_constant ("make-music");
 239   SCM rv = scm_call_1 (make_music_proc, sym);
 240
 241   /* UGH. */
 242   Music *m = unsmob_music (rv);
 243   m->protect ();
 244   return m;
 245 }
 246
 247 MAKE_SCHEME_CALLBACK (Music, duration_length_callback, 1);
 248 SCM
 249 Music::duration_length_callback (SCM m)
 250 {
 251   Music *me = unsmob_music (m);
 252   Duration *d = unsmob_duration (me->get_property ("duration"));
 253
 254   Moment mom;
 255   if (d)
 256     mom = d->get_length ();
 257   return mom.smobbed_copy ();
 258 }
 259
 260 Music *
 261 unsmob_music (SCM m)
 262 {
 263   return dynamic_cast<Music*> (unsmob_prob (m));
 264 }
 265