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