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