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   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
 185 Music::internal_set_mus_property (SCM s, SCM v)
 186 {
 187 #ifndef NDEBUG
 188   if (internal_type_checking_global_b)
 189     assert (type_check_assignment (s, v, ly_symbol2scm ("music-type?")));
 190 #endif
 191
 192   mutable_property_alist_ =  scm_assq_set_x (mutable_property_alist_, s, v);
 193 }
 194
 195
 196
 197 #include "main.hh"
 198
 199 void
 200 Music::set_spot (Input ip)
 201 {
 202   set_mus_property ("origin", make_input (ip));
 203 }
 204
 205 Input*
 206 Music::origin () const
 207 {
 208   Input *ip = unsmob_input (get_mus_property ("origin"));
 209   return ip ? ip : & dummy_input_global;
 210 }
 211
 212
 213 Music::~Music ()
 214 {
 215
 216 }
 217
 218 LY_DEFINE(ly_get_mus_property,
 219           "ly-get-mus-property", 2, 0, 0,  (SCM mus, SCM sym),
 220           "Get the property @var{sym} of music expression @var{mus}.")
 221 {
 222   Music * sc = unsmob_music (mus);
 223   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music");
 224   SCM_ASSERT_TYPE(gh_symbol_p(sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 225
 226   return sc->internal_get_mus_property (sym);
 227 }
 228
 229 LY_DEFINE(ly_set_mus_property,
 230           "ly-set-mus-property!", 3, 0, 0,
 231           (SCM mus, SCM sym, SCM val),
 232           "Set property @var{sym} in music expression @var{mus} to @var{val}.")
 233 {
 234   Music * sc = unsmob_music (mus);
 235   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "grob");
 236   SCM_ASSERT_TYPE(gh_symbol_p(sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 237
 238   bool ok = type_check_assignment (sym, val, ly_symbol2scm ("music-type?"));
 239   if (ok)
 240     {
 241       sc->internal_set_mus_property (sym, val);
 242     }
 243
 244   return SCM_UNSPECIFIED;
 245 }
 246
 247
 248 // to do  property args
 249 LY_DEFINE(ly_make_music,
 250           "ly-make-music", 1, 0, 0,  (SCM type),
 251           "
 252 Make a music object/expression of type @var{name}. Warning: this
 253 interface will likely change in the near future.
 254
 255
 256
 257 Music is the data type that music expressions are stored in. The data
 258 type does not yet offer many manipulations.
 259 ")
 260 {
 261   SCM_ASSERT_TYPE(gh_string_p(type), type, SCM_ARG1, __FUNCTION__, "string");
 262
 263   SCM s = make_music (ly_scm2string (type))->self_scm ();
 264   scm_gc_unprotect_object (s);
 265
 266   return s;
 267 }
 268
 269 LY_DEFINE(ly_music_name, "ly-music-name", 1, 0, 0,
 270   (SCM mus),
 271   "Return the name of @var{music}.")
 272 {
 273   Music * m = unsmob_music (mus);
 274   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__ ,"music");
 275
 276   const char * nm = classname (m);
 277   return ly_str02scm (nm);
 278 }
 279
 280 LY_DEFINE(ly_music_list_p,"music-list?", 1, 0, 0,
 281   (SCM l),"Type predicate: return true if @var{l} is a list of music objects.")
 282 {
 283   if (scm_list_p (l) != SCM_BOOL_T)
 284     return SCM_BOOL_F;
 285
 286   while (gh_pair_p (l))
 287     {
 288       if (!unsmob_music (gh_car (l)))
 289         return SCM_BOOL_F;
 290       l =gh_cdr (l);
 291     }
 292   return SCM_BOOL_T;
 293 }
 294 ADD_MUSIC(Music);
 295