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 duration and supports both time compression
  25   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 void
 240 Music::send_to_context (Context *c)
 241 {
 242   send_stream_event (c, "MusicEvent",
 243                      ly_symbol2scm("music"), self_scm (), 0);
 244 }
 245
 246 Music *
 247 make_music_by_name (SCM sym)
 248 {
 249   SCM make_music_proc = ly_lily_module_constant ("make-music");
 250   SCM rv = scm_call_1 (make_music_proc, sym);
 251
 252   /* UGH. */
 253   Music *m = unsmob_music (rv);
 254   m->protect ();
 255   return m;
 256 }
 257
 258 MAKE_SCHEME_CALLBACK (Music, duration_length_callback, 1);
 259 SCM
 260 Music::duration_length_callback (SCM m)
 261 {
 262   Music *me = unsmob_music (m);
 263   Duration *d = unsmob_duration (me->get_property ("duration"));
 264
 265   Moment mom;
 266   if (d)
 267     mom = d->get_length ();
 268   return mom.smobbed_copy ();
 269 }
 270
 271 Music *
 272 unsmob_music (SCM m)
 273 {
 274   return dynamic_cast<Music*> (unsmob_prob (m));
 275 }
 276