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