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