lily/music.cc

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