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 "debug.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   immutable_property_alist_ = SCM_EOL;
  38   mutable_property_alist_ = SCM_EOL;
  39   smobify_self ();
  40 }
  41
  42 Music::Music (Music const &m)
  43 {
  44   immutable_property_alist_ = m.immutable_property_alist_;
  45   mutable_property_alist_ = SCM_EOL;
  46
  47   /*
  48     First we smobify_self, then we copy over the stuff.  If we don't,
  49     stack vars that hold the copy might be optimized away, meaning
  50     that they won't be protected from GC.
  51    */
  52   smobify_self ();
  53   mutable_property_alist_ = ly_deep_mus_copy (m.mutable_property_alist_);
  54   set_spot (*m.origin ());
  55 }
  56
  57
  58 Music::Music (SCM l)
  59 {
  60   immutable_property_alist_ = l;
  61   mutable_property_alist_ = SCM_EOL;
  62   smobify_self ();
  63 }
  64
  65
  66 SCM
  67 Music::mark_smob (SCM m)
  68 {
  69   Music * mus = (Music *)SCM_CELL_WORD_1 (m);
  70   scm_gc_mark (mus->immutable_property_alist_);
  71   scm_gc_mark (mus->mutable_property_alist_);
  72   return SCM_EOL;
  73 }
  74
  75 void
  76 Music::compress (Moment)
  77 {
  78 }
  79
  80
  81
  82 Moment
  83 Music::length_mom () const
  84 {
  85   SCM l = get_mus_property ("length");
  86   if (unsmob_moment (l))
  87     return *unsmob_moment (l);
  88   else if (gh_procedure_p (l))
  89     {
  90       SCM res = gh_call1 (l, self_scm ());
  91       return *unsmob_moment (res);
  92     }
  93
  94   return 0;
  95 }
  96
  97 Moment
  98 Music::start_mom () const
  99 {
 100   SCM l = get_mus_property ("start-moment-function");
 101   if (gh_procedure_p (l))
 102     {
 103       SCM res = gh_call1 (l, self_scm ());
 104       return *unsmob_moment (res);
 105     }
 106
 107   Moment m ;
 108   return m;
 109 }
 110
 111 void
 112 print_alist (SCM a, SCM port)
 113 {
 114   /*
 115     SCM_EOL  -> catch malformed lists.
 116   */
 117   for (SCM s = a; s != SCM_EOL; s = ly_cdr (s))
 118     {
 119       scm_display (ly_caar (s), port);
 120       scm_puts (" = ", port);
 121       scm_write (ly_cdar (s), port);
 122       scm_puts ("\n", port);
 123     }
 124 }
 125
 126 int
 127 Music::print_smob (SCM s, SCM p, scm_print_state*)
 128 {
 129   scm_puts ("#<Music ", p);
 130   Music* m = unsmob_music (s);
 131   scm_puts (classname (m),p);
 132
 133   print_alist (m->mutable_property_alist_, p);
 134   print_alist (m->immutable_property_alist_, p);
 135
 136   scm_puts (">",p);
 137   return 1;
 138 }
 139
 140 Pitch
 141 Music::to_relative_octave (Pitch m)
 142 {
 143   return m;
 144 }
 145
 146
 147 void
 148 Music::transpose (Pitch delta)
 149 {
 150   Pitch *p = unsmob_pitch (get_mus_property ("pitch"));
 151   if (!p)
 152     return ;
 153
 154   Pitch np = *p;
 155   np.transpose (delta);
 156
 157   if (abs (np.alteration_i_) > 2)
 158     {
 159         warning (_f ("Transposition by %s makes accidental larger than two",
 160           delta.str ()));
 161     }
 162
 163   set_mus_property ("pitch", np.smobbed_copy ());
 164 }
 165
 166 IMPLEMENT_TYPE_P (Music, "music?");
 167
 168 IMPLEMENT_SMOBS (Music);
 169 IMPLEMENT_DEFAULT_EQUAL_P (Music);
 170
 171 /****************************/
 172
 173 SCM
 174 Music::internal_get_mus_property (SCM sym) const
 175 {
 176   SCM s = scm_sloppy_assq (sym, mutable_property_alist_);
 177   if (s != SCM_BOOL_F)
 178     return ly_cdr (s);
 179
 180   s = scm_sloppy_assq (sym, immutable_property_alist_);
 181   return (s == SCM_BOOL_F) ? SCM_EOL : ly_cdr (s);
 182 }
 183
 184 void paranoia_check (Music*);
 185
 186 void
 187 Music::internal_set_mus_property (SCM s, SCM v)
 188 {
 189 #ifndef NDEBUG
 190   if (internal_type_checking_global_b)
 191     assert (type_check_assignment (s, v, ly_symbol2scm ("music-type?")));
 192 #endif
 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__, "grob");
 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__, "grob");
 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
 266   SCM s = get_music (ly_scm2string (type))->self_scm ();
 267   scm_gc_unprotect_object (s);
 268
 269   return s;
 270 }
 271
 272 LY_DEFINE(ly_music_name, "ly-music-name", 1, 0, 0,
 273   (SCM mus),
 274   "Return the name of @var{music}.")
 275 {
 276   Music * m = unsmob_music (mus);
 277   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__ ,"music");
 278
 279   const char * nm = classname (m);
 280   return ly_str02scm (nm);
 281 }
 282
 283 LY_DEFINE(ly_music_list_p,"music-list?", 1, 0, 0,
 284   (SCM l),"Type predicate: return true if @var{l} is a list of music objects.")
 285 {
 286   if (scm_list_p (l) != SCM_BOOL_T)
 287     return SCM_BOOL_F;
 288
 289   while (gh_pair_p (l))
 290     {
 291       if (!unsmob_music (gh_car (l)))
 292         return SCM_BOOL_F;
 293       l =gh_cdr (l);
 294     }
 295   return SCM_BOOL_T;
 296 }
 297 ADD_MUSIC(Music);
 298