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