lily/music.cc

   1 /*
   2   music.cc -- implement Music
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 1997--2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7 */
   8
   9 #include "main.hh"
  10 #include "input-smob.hh"
  11 #include "music.hh"
  12 #include "music-list.hh"
  13 #include "warn.hh"
  14 #include "pitch.hh"
  15 #include "ly-smobs.icc"
  16
  17
  18 SCM ly_deep_mus_copy (SCM);
  19
  20 bool
  21 Music::internal_is_music_type (SCM k)const
  22 {
  23   SCM ifs = get_property ("types");
  24
  25   return scm_memq (k, ifs) != SCM_BOOL_F;
  26 }
  27
  28 String
  29 Music::name () const
  30 {
  31   SCM nm = get_property ("name");
  32   if (gh_symbol_p (nm))
  33     {
  34       return ly_symbol2string (nm);
  35     }
  36   else
  37     {
  38       return classname (this);
  39     }
  40 }
  41
  42
  43
  44 Music::Music (Music const &m)
  45 {
  46   immutable_property_alist_ = m.immutable_property_alist_;
  47   mutable_property_alist_ = SCM_EOL;
  48   self_scm_ = SCM_EOL;
  49
  50   /*
  51     First we smobify_self, then we copy over the stuff.  If we don't,
  52     stack vars that hold the copy might be optimized away, meaning
  53     that they won't be protected from GC.
  54    */
  55   smobify_self ();
  56   mutable_property_alist_ = ly_deep_mus_copy (m.mutable_property_alist_);
  57   set_spot (*m.origin ());
  58 }
  59
  60 Music::Music ()
  61 {
  62   self_scm_ = SCM_EOL;
  63   immutable_property_alist_ = SCM_EOL;
  64   mutable_property_alist_ = SCM_EOL;
  65   smobify_self ();
  66 }
  67
  68 SCM
  69 Music::get_property_alist (bool m) const
  70 {
  71   return (m) ? mutable_property_alist_ : immutable_property_alist_;
  72 }
  73
  74 SCM
  75 Music::mark_smob (SCM m)
  76 {
  77   Music * mus = (Music *)SCM_CELL_WORD_1 (m);
  78   scm_gc_mark (mus->immutable_property_alist_);
  79   scm_gc_mark (mus->mutable_property_alist_);
  80   return SCM_EOL;
  81 }
  82
  83 Moment
  84 Music::get_length () const
  85 {
  86   SCM l = get_property ("length");
  87   if (unsmob_moment (l))
  88     return *unsmob_moment (l);
  89   else if (gh_procedure_p (l))
  90     {
  91       SCM res = gh_call1 (l, self_scm ());
  92       return *unsmob_moment (res);
  93     }
  94
  95   return 0;
  96 }
  97
  98 Moment
  99 Music::start_mom () const
 100 {
 101   SCM l = get_property ("start-moment-function");
 102   if (gh_procedure_p (l))
 103     {
 104       SCM res = gh_call1 (l, self_scm ());
 105       return *unsmob_moment (res);
 106     }
 107
 108   Moment m ;
 109   return m;
 110 }
 111
 112 void
 113 print_alist (SCM a, SCM port)
 114 {
 115   /*
 116     SCM_EOL  -> catch malformed lists.
 117   */
 118   for (SCM s = a; gh_pair_p (s); s = ly_cdr (s))
 119     {
 120       scm_display (ly_caar (s), port);
 121       scm_puts (" = ", port);
 122       scm_write (ly_cdar (s), port);
 123       scm_puts ("\n", port);
 124     }
 125 }
 126
 127 int
 128 Music::print_smob (SCM s, SCM p, scm_print_state*)
 129 {
 130   scm_puts ("#<Music ", p);
 131   Music* m = unsmob_music (s);
 132
 133   SCM nm = m->get_property ("name");
 134   if (gh_symbol_p (nm) || gh_string_p (nm))
 135     {
 136       scm_display (nm, p);
 137     }
 138   else
 139     {
 140       scm_puts (classname (m),p);
 141     }
 142
 143   /*
 144     Printing properties takes a lot of time, especially during backtraces.
 145     For inspecting, it is better to explicitly use an inspection
 146     function.
 147    */
 148
 149   scm_puts (">",p);
 150   return 1;
 151 }
 152
 153 Pitch
 154 Music::to_relative_octave (Pitch p)
 155 {
 156   SCM elt = get_property ("element");
 157
 158   if (Music* m = unsmob_music (elt))
 159     p = m->to_relative_octave (p);
 160
 161   p = music_list_to_relative (get_property ("elements"),
 162                               p, false);
 163   return p;
 164 }
 165
 166 void
 167 Music::compress (Moment factor)
 168 {
 169   SCM elt = get_property ("element");
 170
 171   if (Music* m = unsmob_music (elt))
 172     m->compress (factor);
 173
 174   compress_music_list (get_property ("elements"), factor);
 175 }
 176
 177
 178 void
 179 Music::transpose (Pitch delta)
 180 {
 181   SCM elt = get_property ("element");
 182
 183   if (Music* m = unsmob_music (elt))
 184     m->transpose (delta);
 185
 186   transpose_music_list (get_property ("elements"), delta);
 187 }
 188
 189
 190 IMPLEMENT_TYPE_P (Music, "ly:music?");
 191
 192 IMPLEMENT_SMOBS (Music);
 193 IMPLEMENT_DEFAULT_EQUAL_P (Music);
 194
 195 /****************************/
 196
 197 SCM
 198 Music::internal_get_property (SCM sym) const
 199 {
 200   SCM s = scm_sloppy_assq (sym, mutable_property_alist_);
 201   if (s != SCM_BOOL_F)
 202     return ly_cdr (s);
 203
 204   s = scm_sloppy_assq (sym, immutable_property_alist_);
 205   return (s == SCM_BOOL_F) ? SCM_EOL : ly_cdr (s);
 206 }
 207
 208 void
 209 Music::internal_set_property (SCM s, SCM v)
 210 {
 211   if (internal_type_checking_global_b)
 212     if (!type_check_assignment (s, v, ly_symbol2scm ("music-type?")))
 213       abort ();
 214
 215   mutable_property_alist_ =  scm_assq_set_x (mutable_property_alist_, s, v);
 216 }
 217
 218 #include "main.hh"
 219
 220 void
 221 Music::set_spot (Input ip)
 222 {
 223   set_property ("origin", make_input (ip));
 224 }
 225
 226 Input*
 227 Music::origin () const
 228 {
 229   Input *ip = unsmob_input (get_property ("origin"));
 230   return ip ? ip : & dummy_input_global;
 231 }
 232
 233
 234 Music::~Music ()
 235 {
 236
 237 }
 238
 239 LY_DEFINE(ly_music_length,
 240           "ly:music-length", 1, 0, 0,  (SCM mus),
 241           "Get the length (in musical time) of music expression @var{mus}.")
 242 {
 243   Music * sc = unsmob_music (mus);
 244   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 245   return sc->get_length().smobbed_copy();
 246 }
 247
 248 LY_DEFINE(ly_music_property,
 249           "ly:music-property", 2, 0, 0,  (SCM mus, SCM sym),
 250           "Get the property @var{sym} of music expression @var{mus}.\n"
 251           "If @var{sym} is undefined, return @code{'()}.\n" )
 252 {
 253   Music * sc = unsmob_music (mus);
 254   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 255   SCM_ASSERT_TYPE(gh_symbol_p (sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 256
 257   return sc->internal_get_property (sym);
 258 }
 259
 260 LY_DEFINE(ly_music_set_property,
 261           "ly:music-set-property!", 3, 0, 0,
 262           (SCM mus, SCM sym, SCM val),
 263           "Set property @var{sym} in music expression @var{mus} to @var{val}.")
 264 {
 265   Music * sc = unsmob_music (mus);
 266   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 267   SCM_ASSERT_TYPE(gh_symbol_p (sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 268
 269   bool ok = type_check_assignment (sym, val, ly_symbol2scm ("music-type?"));
 270   if (ok)
 271     {
 272       sc->internal_set_property (sym, val);
 273     }
 274
 275   return SCM_UNSPECIFIED;
 276 }
 277
 278
 279 LY_DEFINE(ly_music_name, "ly:music-name", 1, 0, 0,
 280   (SCM mus),
 281   "Return the name of @var{music}.")
 282 {
 283   Music * m = unsmob_music (mus);
 284   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__ ,"music");
 285
 286   const char * nm = classname (m);
 287   return scm_makfrom0str (nm);
 288 }
 289
 290
 291
 292 // to do  property args
 293 LY_DEFINE(ly_extended_make_music,
 294           "ly:make-bare-music", 2, 0, 0,  (SCM type, SCM props),
 295           "Make a C++ music object of type @var{type}, initialize with\n"
 296           "@var{props}. \n\n"
 297           ""
 298           "This function is for internal use, and is only called by "
 299           "@code{make-music-by-name}, which is the preferred interface "
 300           "for creating music objects. "
 301           )
 302 {
 303   SCM_ASSERT_TYPE(gh_string_p (type), type, SCM_ARG1, __FUNCTION__, "string");
 304
 305   SCM s = make_music (ly_scm2string (type))->self_scm ();
 306   unsmob_music (s)->immutable_property_alist_ = props;
 307   scm_gc_unprotect_object (s);
 308   return s;
 309 }
 310
 311 // to do  property args
 312 LY_DEFINE(ly_get_mutable_properties,
 313           "ly:get-mutable-properties", 1, 0, 0,  (SCM mus),
 314           "Return an alist containing the mutable properties of @var{mus}.\n"
 315           "The immutable properties are not available; they should be initialized\n"
 316           "by the  @code{make-music-by-name} function.\n"
 317           )
 318 {
 319   Music *m = unsmob_music (mus);
 320   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__, "music");
 321
 322   return m->get_property_alist (true);
 323 }
 324
 325 LY_DEFINE(ly_music_list_p,"ly:music-list?", 1, 0, 0,
 326   (SCM l),"Type predicate: return true if @var{l} is a list of music objects.")
 327 {
 328   if (scm_list_p (l) != SCM_BOOL_T)
 329     return SCM_BOOL_F;
 330
 331   while (gh_pair_p (l))
 332     {
 333       if (!unsmob_music (gh_car (l)))
 334         return SCM_BOOL_F;
 335       l =gh_cdr (l);
 336     }
 337   return SCM_BOOL_T;
 338 }
 339 ADD_MUSIC(Music);
 340
 341
 342
 343 LY_DEFINE(ly_deep_mus_copy,
 344           "ly:music-deep-copy", 1,0,0, (SCM m),
 345           "Copy @var{m} and all sub expressions of @var{m}")
 346 {
 347   if (unsmob_music (m))
 348     {
 349       SCM ss =  unsmob_music (m)->clone ()->self_scm ();
 350       scm_gc_unprotect_object (ss);
 351       return ss;
 352     }
 353   else if (gh_pair_p (m))
 354     {
 355       return gh_cons (ly_deep_mus_copy (ly_car (m)), ly_deep_mus_copy (ly_cdr (m)));
 356     }
 357   else
 358     return m;
 359 }
 360
 361 LY_DEFINE(ly_music_transpose,
 362           "ly:music-transpose", 2,0,0, (SCM m, SCM p),
 363           "Transpose @var{m} such that central C is mapped to @var{p}. "
 364 "Return @var{m}.")
 365 {
 366   Music * sc = unsmob_music (m);
 367   Pitch * sp = unsmob_pitch (p);
 368   SCM_ASSERT_TYPE(sc, m, SCM_ARG1, __FUNCTION__, "music");
 369   SCM_ASSERT_TYPE(sp, p, SCM_ARG2, __FUNCTION__, "pitch");
 370
 371   sc->transpose (*sp);
 372   return sc->self_scm();        // SCM_UNDEFINED ?
 373 }
 374
 375
 376 SCM make_music_proc;
 377
 378
 379 Music*
 380 make_music_by_name (SCM sym)
 381 {
 382   if (!make_music_proc)
 383     make_music_proc = scm_primitive_eval (ly_symbol2scm ("make-music-by-name"));
 384
 385   SCM rv = scm_call_1 (make_music_proc, sym);
 386
 387   /*
 388     UGH.
 389   */
 390   scm_gc_protect_object (rv);
 391   return unsmob_music (rv);
 392 }
 393