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   SCM c =ly_deep_mus_copy (m.mutable_property_alist_);
  46   mutable_property_alist_ = c;
  47
  48   smobify_self ();
  49
  50   set_spot (*m.origin ());
  51 }
  52
  53
  54 Music::Music (SCM l)
  55 {
  56   immutable_property_alist_ = l;
  57   mutable_property_alist_ = SCM_EOL;
  58   smobify_self ();
  59 }
  60
  61
  62 SCM
  63 Music::mark_smob (SCM m)
  64 {
  65   Music * mus = (Music *)SCM_CELL_WORD_1 (m);
  66   scm_gc_mark (mus->immutable_property_alist_);
  67   scm_gc_mark (mus->mutable_property_alist_);
  68   return SCM_EOL;
  69 }
  70
  71 void
  72 Music::compress (Moment)
  73 {
  74 }
  75
  76
  77
  78 Moment
  79 Music::length_mom () const
  80 {
  81   SCM l = get_mus_property ("length");
  82   if (unsmob_moment (l))
  83     return *unsmob_moment (l);
  84   else if (gh_procedure_p (l))
  85     {
  86       SCM res = gh_call1 (l, self_scm ());
  87       return *unsmob_moment (res);
  88     }
  89
  90   return 0;
  91 }
  92
  93 Moment
  94 Music::start_mom () const
  95 {
  96   SCM l = get_mus_property ("start-moment-function");
  97   if (gh_procedure_p (l))
  98     {
  99       SCM res = gh_call1 (l, self_scm ());
 100       return *unsmob_moment (res);
 101     }
 102
 103   Moment m ;
 104   return m;
 105 }
 106
 107 void
 108 print_alist (SCM a, SCM port)
 109 {
 110   for (SCM s = a; gh_pair_p (s); s = ly_cdr (s))
 111     {
 112       scm_display (ly_caar (s), port);
 113       scm_puts (" = ", port);
 114       scm_write (ly_cdar (s), port);
 115       scm_puts ("\n", port);
 116     }
 117 }
 118
 119 int
 120 Music::print_smob (SCM s, SCM p, scm_print_state*)
 121 {
 122   scm_puts ("#<Music ", p);
 123   Music* m = unsmob_music (s);
 124   scm_puts (classname (m),p);
 125
 126   print_alist (m->mutable_property_alist_, p);
 127   print_alist (m->immutable_property_alist_, p);
 128
 129   scm_puts (">",p);
 130   return 1;
 131 }
 132
 133 Pitch
 134 Music::to_relative_octave (Pitch m)
 135 {
 136   return m;
 137 }
 138
 139
 140 void
 141 Music::transpose (Pitch delta)
 142 {
 143   Pitch *p = unsmob_pitch (get_mus_property ("pitch"));
 144   if (!p)
 145     return ;
 146
 147   Pitch np = *p;
 148   np.transpose (delta);
 149
 150   if (abs (np.alteration_i_) > 2)
 151     {
 152         warning (_f ("Transposition by %s makes accidental larger than two",
 153           delta.str ()));
 154     }
 155
 156   set_mus_property ("pitch", np.smobbed_copy ());
 157 }
 158
 159 IMPLEMENT_TYPE_P (Music, "music?");
 160
 161 IMPLEMENT_SMOBS (Music);
 162 IMPLEMENT_DEFAULT_EQUAL_P (Music);
 163
 164 /****************************/
 165
 166 SCM
 167 Music::internal_get_mus_property (SCM sym) const
 168 {
 169   SCM s = scm_sloppy_assq (sym, mutable_property_alist_);
 170   if (s != SCM_BOOL_F)
 171     return ly_cdr (s);
 172
 173   s = scm_sloppy_assq (sym, immutable_property_alist_);
 174   return (s == SCM_BOOL_F) ? SCM_EOL : ly_cdr (s);
 175 }
 176
 177 void
 178 Music::internal_set_mus_property (SCM s, SCM v)
 179 {
 180 #ifndef NDEBUG
 181   if (internal_type_checking_global_b)
 182     assert (type_check_assignment (s, v, ly_symbol2scm ("music-type?")));
 183 #endif
 184
 185   mutable_property_alist_ = scm_assq_set_x (mutable_property_alist_, s, v);
 186 }
 187
 188 #include "main.hh"
 189
 190 void
 191 Music::set_spot (Input ip)
 192 {
 193   set_mus_property ("origin", make_input (ip));
 194 }
 195
 196 Input*
 197 Music::origin () const
 198 {
 199   Input *ip = unsmob_input (get_mus_property ("origin"));
 200   return ip ? ip : & dummy_input_global;
 201 }
 202
 203
 204 Music::~Music ()
 205 {
 206
 207 }
 208
 209 SCM
 210 ly_get_mus_property (SCM mus, SCM sym)
 211 {
 212   Music * sc = unsmob_music (mus);
 213   SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "grob");
 214   SCM_ASSERT_TYPE(gh_symbol_p(sym), sym, SCM_ARG2, __FUNCTION__, "symbol");
 215
 216       return sc->internal_get_mus_property (sym);
 217
 218 }
 219
 220
 221 SCM
 222 ly_set_mus_property (SCM mus, SCM sym, SCM val)
 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   bool ok = type_check_assignment (sym, val, ly_symbol2scm ("music-type?"));
 229   if (ok)
 230     {
 231       sc->internal_set_mus_property (sym, val);
 232     }
 233
 234   return SCM_UNSPECIFIED;
 235 }
 236
 237
 238 // to do  property args
 239 SCM
 240 ly_make_music (SCM type)
 241 {
 242   SCM_ASSERT_TYPE(gh_string_p(type), type, SCM_ARG1, __FUNCTION__, "string");
 243
 244
 245   SCM s = get_music (ly_scm2string (type))->self_scm ();
 246   scm_gc_unprotect_object (s);
 247
 248   return s;
 249 }
 250
 251 SCM
 252 ly_music_name (SCM mus)
 253 {
 254   Music * m = unsmob_music (mus);
 255   SCM_ASSERT_TYPE(m, mus, SCM_ARG1, __FUNCTION__ ,"music");
 256
 257   const char * nm = classname (m);
 258   return ly_str02scm (nm);
 259 }
 260
 261 SCM
 262 ly_music_list_p (SCM l)
 263 {
 264   if (scm_list_p (l) != SCM_BOOL_T)
 265     return SCM_BOOL_F;
 266
 267   while (gh_pair_p (l))
 268     {
 269       if (!unsmob_music (gh_car (l)))
 270         return SCM_BOOL_F;
 271       l =gh_cdr (l);
 272     }
 273   return SCM_BOOL_T;
 274 }
 275
 276 static void
 277 init_functions ()
 278 {
 279   scm_c_define_gsubr ("music-list?", 1, 0, 0, (Scheme_function_unknown)ly_music_list_p);
 280   scm_c_define_gsubr ("ly-get-mus-property", 2, 0, 0, (Scheme_function_unknown)ly_get_mus_property);
 281   scm_c_define_gsubr ("ly-set-mus-property", 3, 0, 0, (Scheme_function_unknown)ly_set_mus_property);
 282   scm_c_define_gsubr ("ly-make-music", 1, 0, 0, (Scheme_function_unknown)ly_make_music);
 283   scm_c_define_gsubr ("ly-music-name", 1, 0, 0, (Scheme_function_unknown)ly_music_name);
 284 }
 285 ADD_SCM_INIT_FUNC (musicscm,init_functions);
 286 ADD_MUSIC(Music);