lily/music.cc

   1 /*
   2   music.cc -- implement Music
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c)  1997--2003 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_mus_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_mus_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_mus_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_mus_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_mus_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_mus_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_mus_property ("elements"),
 162                               p, false);
 163   return p;
 164 }
 165
 166 void
 167 Music::compress (Moment factor)
 168 {
 169   SCM elt = get_mus_property ("element");
 170
 171   if (Music* m = unsmob_music (elt))
 172     m->compress (factor);
 173
 174   compress_music_list (get_mus_property ("elements"), factor);
 175 }
 176
 177
 178 void
 179 Music::transpose (Pitch delta)
 180 {
 181   SCM elt = get_mus_property ("element");
 182
 183   if (Music* m = unsmob_music (elt))
 184     m->transpose (delta);
 185
 186   transpose_music_list (get_mus_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_mus_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_mus_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
 219
 220 #include "main.hh"
 221
 222 void
 223 Music::set_spot (Input ip)
 224 {
 225   set_mus_property ("origin", make_input (ip));
 226 }
 227
 228 Input*
 229 Music::origin () const
 230 {
 231   Input *ip = unsmob_input (get_mus_property ("origin"));
 232   return ip ? ip : & dummy_input_global;
 233 }
 234
 235
 236 Music::~Music ()
 237 {
 238
 239 }
 240
 241 LY_DEFINE(ly_get_music_length,
 242           "ly:get-music-length", 1, 0, 0,  (SCM mus),
 243           "Get the length (in musical time) of music expression @var{mus}.")
 244 {
 245   Music * sc = unsmob_music (mus);
 246   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 247   return sc->get_length().smobbed_copy();
 248 }
 249
 250 LY_DEFINE(ly_get_mus_property,
 251           "ly:get-mus-property", 2, 0, 0,  (SCM mus, SCM sym),
 252           "Get the property @var{sym} of music expression @var{mus}.\n"
 253           "If @var{sym} is undefined, return @code{'()}.\n"
 254           )
 255 {
 256   Music * sc = unsmob_music (mus);
 257   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 258   SCM_ASSERT_TYPE(gh_symbol_p (sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 259
 260   return sc->internal_get_mus_property (sym);
 261 }
 262
 263 LY_DEFINE(ly_set_mus_property,
 264           "ly:set-mus-property!", 3, 0, 0,
 265           (SCM mus, SCM sym, SCM val),
 266           "Set property @var{sym} in music expression @var{mus} to @var{val}.")
 267 {
 268   Music * sc = unsmob_music (mus);
 269   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 270   SCM_ASSERT_TYPE(gh_symbol_p (sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 271
 272   bool ok = type_check_assignment (sym, val, ly_symbol2scm ("music-type?"));
 273   if (ok)
 274     {
 275       sc->internal_set_mus_property (sym, val);
 276     }
 277
 278   return SCM_UNSPECIFIED;
 279 }
 280
 281
 282 LY_DEFINE(ly_music_name, "ly:music-name", 1, 0, 0,
 283   (SCM mus),
 284   "Return the name of @var{music}.")
 285 {
 286   Music * m = unsmob_music (mus);
 287   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__ ,"music");
 288
 289   const char * nm = classname (m);
 290   return scm_makfrom0str (nm);
 291 }
 292
 293
 294
 295 // to do  property args
 296 LY_DEFINE(ly_extended_make_music,
 297           "ly:make-bare-music", 2, 0, 0,  (SCM type, SCM props),
 298           "Make a music object/expression of type @var{type}, init with\n"
 299 "@var{props}. Warning: this interface will likely change in the near\n"
 300 "future.\n"
 301 "\n"
 302 "Music is the data type that music expressions are stored in. The data\n"
 303 "type does not yet offer many manipulations.\n"
 304 "\n"
 305 "WARNING: only for internal use. Please use make-music-by-name. \n"
 306 )
 307 {
 308   SCM_ASSERT_TYPE(gh_string_p (type), type, SCM_ARG1, __FUNCTION__, "string");
 309
 310   SCM s = make_music (ly_scm2string (type))->self_scm ();
 311   unsmob_music (s)->immutable_property_alist_ = props;
 312   scm_gc_unprotect_object (s);
 313   return s;
 314 }
 315
 316 // to do  property args
 317 LY_DEFINE(ly_get_mutable_properties,
 318           "ly:get-mutable-properties", 1, 0, 0,  (SCM mus),
 319 "Return an alist signifying the mutable properties of @var{mus}.\n"
 320 "The immutable properties are not available; they should be initialized\n"
 321 "by the functions make-music-by-name function.\n"
 322 )
 323 {
 324   Music *m = unsmob_music (mus);
 325   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__, "music");
 326
 327   return m->get_property_alist (true);
 328 }
 329
 330 LY_DEFINE(ly_music_list_p,"music-list?", 1, 0, 0,
 331   (SCM l),"Type predicate: return true if @var{l} is a list of music objects.")
 332 {
 333   if (scm_list_p (l) != SCM_BOOL_T)
 334     return SCM_BOOL_F;
 335
 336   while (gh_pair_p (l))
 337     {
 338       if (!unsmob_music (gh_car (l)))
 339         return SCM_BOOL_F;
 340       l =gh_cdr (l);
 341     }
 342   return SCM_BOOL_T;
 343 }
 344 ADD_MUSIC(Music);
 345
 346
 347
 348 LY_DEFINE(ly_deep_mus_copy,
 349           "ly:music-deep-copy", 1,0,0, (SCM m),
 350           "Copy @var{m} and all sub expressions of @var{m}")
 351 {
 352   if (unsmob_music (m))
 353     {
 354       SCM ss =  unsmob_music (m)->clone ()->self_scm ();
 355       scm_gc_unprotect_object (ss);
 356       return ss;
 357     }
 358   else if (gh_pair_p (m))
 359     {
 360       return gh_cons (ly_deep_mus_copy (ly_car (m)), ly_deep_mus_copy (ly_cdr (m)));
 361     }
 362   else
 363     return m;
 364 }
 365
 366 LY_DEFINE(ly_music_transpose,
 367           "ly:music-transpose", 2,0,0, (SCM m, SCM p),
 368           "Transpose @var{m} such that central C is mapped to @var{p}. "
 369 "Return @var{m}.")
 370 {
 371   Music * sc = unsmob_music (m);
 372   Pitch * sp = unsmob_pitch (p);
 373   SCM_ASSERT_TYPE(sc, m, SCM_ARG1, __FUNCTION__, "music");
 374   SCM_ASSERT_TYPE(sp, p, SCM_ARG2, __FUNCTION__, "pitch");
 375
 376   sc->transpose (*sp);
 377   return sc->self_scm();        // SCM_UNDEFINED ?
 378 }
 379
 380
 381 SCM make_music_proc;
 382
 383
 384 Music*
 385 make_music_by_name (SCM sym)
 386 {
 387   if (!make_music_proc)
 388     make_music_proc = scm_primitive_eval (ly_symbol2scm ("make-music-by-name"));
 389
 390   SCM rv = scm_call_1 (make_music_proc, sym);
 391
 392   /*
 393     UGH.
 394   */
 395   scm_gc_protect_object (rv);
 396   return unsmob_music (rv);
 397 }