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