lily/music.cc

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