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_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 #include "main.hh"
 219
 220 void
 221 Music::set_spot (Input ip)
 222 {
 223   set_mus_property ("origin", make_input (ip));
 224 }
 225
 226 Input*
 227 Music::origin () const
 228 {
 229   Input *ip = unsmob_input (get_mus_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_get_mus_property,
 249           "ly:get-mus-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_mus_property (sym);
 258 }
 259
 260 LY_DEFINE(ly_set_mus_property,
 261           "ly:set-mus-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_mus_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 music object/expression of type @var{type}, init with\n"
 296 "@var{props}. Warning: this interface will likely change in the near\n"
 297 "future.\n"
 298 "\n"
 299 "Music is the data type that music expressions are stored in. The data\n"
 300 "type does not yet offer many manipulations.\n"
 301 "\n"
 302 "WARNING: only for internal use. Please use make-music-by-name. \n"
 303 )
 304 {
 305   SCM_ASSERT_TYPE(gh_string_p (type), type, SCM_ARG1, __FUNCTION__, "string");
 306
 307   SCM s = make_music (ly_scm2string (type))->self_scm ();
 308   unsmob_music (s)->immutable_property_alist_ = props;
 309   scm_gc_unprotect_object (s);
 310   return s;
 311 }
 312
 313 // to do  property args
 314 LY_DEFINE(ly_get_mutable_properties,
 315           "ly:get-mutable-properties", 1, 0, 0,  (SCM mus),
 316 "Return an alist signifying the mutable properties of @var{mus}.\n"
 317 "The immutable properties are not available; they should be initialized\n"
 318 "by the functions make-music-by-name function.\n"
 319 )
 320 {
 321   Music *m = unsmob_music (mus);
 322   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__, "music");
 323
 324   return m->get_property_alist (true);
 325 }
 326
 327 LY_DEFINE(ly_music_list_p,"music-list?", 1, 0, 0,
 328   (SCM l),"Type predicate: return true if @var{l} is a list of music objects.")
 329 {
 330   if (scm_list_p (l) != SCM_BOOL_T)
 331     return SCM_BOOL_F;
 332
 333   while (gh_pair_p (l))
 334     {
 335       if (!unsmob_music (gh_car (l)))
 336         return SCM_BOOL_F;
 337       l =gh_cdr (l);
 338     }
 339   return SCM_BOOL_T;
 340 }
 341 ADD_MUSIC(Music);
 342
 343
 344
 345 LY_DEFINE(ly_deep_mus_copy,
 346           "ly:music-deep-copy", 1,0,0, (SCM m),
 347           "Copy @var{m} and all sub expressions of @var{m}")
 348 {
 349   if (unsmob_music (m))
 350     {
 351       SCM ss =  unsmob_music (m)->clone ()->self_scm ();
 352       scm_gc_unprotect_object (ss);
 353       return ss;
 354     }
 355   else if (gh_pair_p (m))
 356     {
 357       return gh_cons (ly_deep_mus_copy (ly_car (m)), ly_deep_mus_copy (ly_cdr (m)));
 358     }
 359   else
 360     return m;
 361 }
 362
 363 LY_DEFINE(ly_music_transpose,
 364           "ly:music-transpose", 2,0,0, (SCM m, SCM p),
 365           "Transpose @var{m} such that central C is mapped to @var{p}. "
 366 "Return @var{m}.")
 367 {
 368   Music * sc = unsmob_music (m);
 369   Pitch * sp = unsmob_pitch (p);
 370   SCM_ASSERT_TYPE(sc, m, SCM_ARG1, __FUNCTION__, "music");
 371   SCM_ASSERT_TYPE(sp, p, SCM_ARG2, __FUNCTION__, "pitch");
 372
 373   sc->transpose (*sp);
 374   return sc->self_scm();        // SCM_UNDEFINED ?
 375 }
 376
 377
 378 SCM make_music_proc;
 379
 380
 381 Music*
 382 make_music_by_name (SCM sym)
 383 {
 384   if (!make_music_proc)
 385     make_music_proc = scm_primitive_eval (ly_symbol2scm ("make-music-by-name"));
 386
 387   SCM rv = scm_call_1 (make_music_proc, sym);
 388
 389   /*
 390     UGH.
 391   */
 392   scm_gc_protect_object (rv);
 393   return unsmob_music (rv);
 394 }
 395