lily/grob-scheme.cc

   1 /*
   2   grob-scheme.cc -- Scheme entry points for the grob datatype
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 1998--2007 Jan Nieuwenhuizen <janneke@gnu.org>
   7   Han-Wen Nienhuys <hanwen@xs4all.nl>
   8 */
   9
  10 #include "warn.hh"              // error ()
  11 #include "item.hh"
  12 #include "output-def.hh"
  13 #include "system.hh"
  14 #include "font-interface.hh"
  15 #include "paper-score.hh"
  16 #include "grob-array.hh"
  17
  18 LY_DEFINE (ly_grob_property_data, "ly:grob-property-data",
  19            2, 0, 0, (SCM grob, SCM sym),
  20            "Retrieve @var{sym} for @var{grob} but don't process callbacks.")
  21 {
  22   Grob *sc = unsmob_grob (grob);
  23
  24   LY_ASSERT_SMOB (Grob, grob, 1);
  25   LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
  26
  27   return sc->get_property_data (sym);
  28 }
  29
  30 LY_DEFINE (ly_grob_set_property_x, "ly:grob-set-property!",
  31            3, 0, 0, (SCM grob, SCM sym, SCM val),
  32            "Set @var{sym} in grob @var{grob} to value @var{val}.")
  33 {
  34   Grob *sc = unsmob_grob (grob);
  35
  36   LY_ASSERT_SMOB (Grob, grob, 1);
  37   LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
  38
  39   if (!ly_is_procedure (val)
  40       && !type_check_assignment (sym, val, ly_symbol2scm ("backend-type?")))
  41     error ("typecheck failed");
  42
  43   sc->set_property (sym, val);
  44   return SCM_UNSPECIFIED;
  45 }
  46
  47 LY_DEFINE (ly_grob_property, "ly:grob-property",
  48            2, 1, 0, (SCM grob, SCM sym, SCM deflt),
  49            "Return the value of a value in grob@tie{}@var{g} of property"
  50            " @var{sym}.  It returns @code{'()} (end-of-list) or"
  51            " @var{deflt} (if specified) if @var{sym} is undefined"
  52            " in@tie{}@var{g}.")
  53 {
  54   Grob *sc = unsmob_grob (grob);
  55
  56   LY_ASSERT_SMOB (Grob, grob, 1);
  57   LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
  58   if (deflt == SCM_UNDEFINED)
  59     deflt = SCM_EOL;
  60
  61   SCM retval = sc->internal_get_property (sym);
  62   if (retval == SCM_EOL)
  63     retval = deflt;
  64
  65   return retval;
  66 }
  67
  68
  69 LY_DEFINE (ly_grob_interfaces, "ly:grob-interfaces",
  70            1, 0, 0, (SCM grob),
  71            "Return the interfaces list of grob @var{grob}.")
  72 {
  73   Grob *sc = unsmob_grob (grob);
  74
  75   LY_ASSERT_SMOB (Grob, grob, 1);
  76
  77   return sc->interfaces ();
  78 }
  79
  80 LY_DEFINE (ly_grob_object, "ly:grob-object",
  81            2, 0, 0, (SCM grob, SCM sym),
  82            "Return the value of a pointer in grob@tie{}@var{g} of property"
  83            " @var{sym}.  It returns @code{'()} (end-of-list) if @var{sym}"
  84            " is undefined in@tie{}@var{g}.")
  85 {
  86   Grob *sc = unsmob_grob (grob);
  87
  88   LY_ASSERT_SMOB (Grob, grob, 1);
  89   LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
  90
  91   return sc->internal_get_object (sym);
  92 }
  93
  94
  95
  96 /* TODO: make difference between scaled and unscalead variable in
  97    calling (i.e different funcs.) */
  98 LY_DEFINE (ly_grob_layout, "ly:grob-layout",
  99            1, 0, 0, (SCM grob),
 100            "Get @code{\\layout} definition from grob @var{grob}.")
 101 {
 102   Grob *sc = unsmob_grob (grob);
 103
 104   LY_ASSERT_SMOB (Grob, grob, 1);
 105
 106   return sc->layout ()->self_scm ();
 107 }
 108
 109 LY_DEFINE (ly_grob_alist_chain, "ly:grob-alist-chain",
 110            1, 1, 0, (SCM grob, SCM global),
 111            "Get an alist chain for grob @var{grob}, with @var{global} as"
 112            " the global default.  If unspecified, @code{font-defaults}"
 113            " from the layout block is taken.")
 114 {
 115   Grob *sc = unsmob_grob (grob);
 116
 117   LY_ASSERT_SMOB (Grob, grob, 1);
 118
 119   if (global == SCM_UNDEFINED)
 120     {
 121       global = sc->layout ()->lookup_variable (ly_symbol2scm ("font-defaults"));
 122       if (global == SCM_UNDEFINED)
 123         global = SCM_EOL;
 124     }
 125
 126   return sc->get_property_alist_chain (global);
 127 }
 128
 129 LY_DEFINE (ly_grob_extent, "ly:grob-extent",
 130            3, 0, 0, (SCM grob, SCM refp, SCM axis),
 131            "Get the extent in @var{axis} direction of @var{grob} relative to"
 132            " the grob @var{refp}.")
 133 {
 134   Grob *sc = unsmob_grob (grob);
 135   Grob *ref = unsmob_grob (refp);
 136
 137
 138   LY_ASSERT_SMOB (Grob, grob, 1);
 139   LY_ASSERT_SMOB (Grob, refp, 2);
 140   LY_ASSERT_TYPE (is_axis, axis, 3);
 141
 142   Axis a = Axis (scm_to_int (axis));
 143
 144
 145   if (ref->common_refpoint (sc, a) != ref)
 146     {
 147       // ugh. should use other error message
 148       SCM_ASSERT_TYPE (false, refp, SCM_ARG2, __FUNCTION__, "common refpoint");
 149     }
 150   return ly_interval2scm (sc->extent (ref, a));
 151 }
 152
 153 LY_DEFINE (ly_grob_robust_relative_extent, "ly:grob-robust-relative-extent",
 154            3, 0, 0, (SCM grob, SCM refp, SCM axis),
 155            "Get the extent in @var{axis} direction of @var{grob} relative to"
 156            " the grob @var{refp}, or @code{(0,0)} if empty.")
 157 {
 158   Grob *sc = unsmob_grob (grob);
 159   Grob *ref = unsmob_grob (refp);
 160
 161
 162   LY_ASSERT_SMOB (Grob, grob, 1);
 163   LY_ASSERT_SMOB (Grob, refp, 2);
 164   LY_ASSERT_TYPE (is_axis, axis, 3);
 165
 166   Axis a = Axis (scm_to_int (axis));
 167
 168   if (ref->common_refpoint (sc, a) != ref)
 169     {
 170       // ugh. should use other error message
 171       SCM_ASSERT_TYPE (false, refp, SCM_ARG2, __FUNCTION__, "common refpoint");
 172     }
 173
 174   return ly_interval2scm (robust_relative_extent (sc, ref, a));
 175 }
 176
 177 LY_DEFINE (ly_grob_relative_coordinate, "ly:grob-relative-coordinate",
 178            3, 0, 0, (SCM grob, SCM refp, SCM axis),
 179            "Get the coordinate in @var{axis} direction of @var{grob} relative"
 180            " to the grob @var{refp}.")
 181 {
 182   Grob *sc = unsmob_grob (grob);
 183   Grob *ref = unsmob_grob (refp);
 184
 185
 186   LY_ASSERT_SMOB (Grob, grob, 1);
 187   LY_ASSERT_SMOB (Grob, refp, 2);
 188   LY_ASSERT_TYPE (is_axis, axis, 3);
 189
 190   Axis a = Axis (scm_to_int (axis));
 191
 192
 193   if (ref->common_refpoint (sc, a) != ref)
 194     {
 195       // ugh. should use other error message
 196       SCM_ASSERT_TYPE (false, refp, SCM_ARG2, __FUNCTION__, "common refpoint");
 197     }
 198
 199   return scm_from_double (sc->relative_coordinate (ref, a));
 200 }
 201
 202
 203 LY_DEFINE (ly_grob_parent, "ly:grob-parent",
 204            2, 0, 0, (SCM grob, SCM axis),
 205            "Get the parent of @var{grob}.  @var{axis} is 0 for the X-axis,"
 206            " 1@tie{}for the Y-axis.")
 207 {
 208   Grob *sc = unsmob_grob (grob);
 209
 210   LY_ASSERT_SMOB (Grob, grob, 1);
 211   LY_ASSERT_TYPE (is_axis, axis, 2);
 212
 213   Grob *par = sc->get_parent (Axis (scm_to_int (axis)));
 214   return par ? par->self_scm () : SCM_EOL;
 215 }
 216
 217 LY_DEFINE (ly_grob_properties, "ly:grob-properties",
 218            1, 0, 0, (SCM grob),
 219            "Get the mutable properties of @var{grob}.")
 220 {
 221   Grob *g = unsmob_grob (grob);
 222
 223   LY_ASSERT_SMOB (Grob, grob, 1);
 224
 225   /* FIXME: uhg? copy/read only? */
 226   return g->mutable_property_alist_;
 227 }
 228
 229 LY_DEFINE (ly_grob_basic_properties, "ly:grob-basic-properties",
 230            1, 0, 0, (SCM grob),
 231            "Get the immutable properties of @var{grob}.")
 232 {
 233   Grob *g = unsmob_grob (grob);
 234
 235   LY_ASSERT_SMOB (Grob, grob, 1);
 236
 237   /* FIXME: uhg? copy/read only? */
 238   return g->immutable_property_alist_;
 239 }
 240
 241 LY_DEFINE (ly_grob_system, "ly:grob-system",
 242            1, 0, 0, (SCM grob),
 243            "Return the system grob of @var{grob}.")
 244 {
 245   Grob *me = unsmob_grob (grob);
 246
 247   LY_ASSERT_SMOB (Grob, grob, 1);
 248
 249   if (System *g = me->get_system ())
 250     return g->self_scm ();
 251
 252   return SCM_EOL;
 253 }
 254
 255 LY_DEFINE (ly_grob_original, "ly:grob-original",
 256            1, 0, 0, (SCM grob),
 257            "Return the unbroken original grob of @var{grob}.")
 258 {
 259   Grob *me = unsmob_grob (grob);
 260
 261   LY_ASSERT_SMOB (Grob, grob, 1);
 262   return me->original () ? me->original ()->self_scm () : me->self_scm ();
 263 }
 264
 265
 266 LY_DEFINE (ly_grob_suicide_x, "ly:grob-suicide!",
 267            1, 0, 0, (SCM grob),
 268            "Kill @var{grob}.")
 269 {
 270   Grob *me = unsmob_grob (grob);
 271
 272   LY_ASSERT_SMOB (Grob, grob, 1);
 273
 274   me->suicide ();
 275   return SCM_UNSPECIFIED;
 276 }
 277
 278 LY_DEFINE (ly_grob_translate_axis_x, "ly:grob-translate-axis!",
 279            3, 0, 0, (SCM grob, SCM d, SCM a),
 280            "Translate @var{g} on axis@tie{}@var{a} over"
 281            " distance@tie{}@var{d}.")
 282 {
 283   Grob *me = unsmob_grob (grob);
 284
 285   LY_ASSERT_SMOB (Grob, grob, 1);
 286   LY_ASSERT_TYPE (scm_is_number, d, 2);
 287   LY_ASSERT_TYPE (is_axis, a, 3);
 288
 289   me->translate_axis (scm_to_double (d), Axis (scm_to_int (a)));
 290   return SCM_UNSPECIFIED;
 291 }
 292
 293 LY_DEFINE (ly_grob_default_font, "ly:grob-default-font",
 294            1, 0, 0, (SCM grob),
 295            "Return the default font for grob @var{gr}.")
 296 {
 297   Grob *gr = unsmob_grob (grob);
 298
 299   LY_ASSERT_SMOB (Grob, grob, 1);
 300
 301   return Font_interface::get_default_font (gr)->self_scm ();
 302 }
 303
 304
 305 /*
 306   TODO: consider swapping order, so we can do
 307
 308   (grob-common-refpoint a b c d e)
 309  */
 310 LY_DEFINE (ly_grob_common_refpoint, "ly:grob-common-refpoint",
 311            3, 0, 0,  (SCM grob, SCM other, SCM axis),
 312            "Find the common refpoint of @var{grob} and @var{other}"
 313            " for @var{axis}.")
 314 {
 315
 316   Grob *gr = unsmob_grob (grob);
 317
 318   LY_ASSERT_SMOB (Grob, grob, 1);
 319   LY_ASSERT_SMOB (Grob, other, 2);
 320
 321   Grob *o = unsmob_grob (other);
 322
 323   LY_ASSERT_TYPE (is_axis, axis, 3);
 324
 325   Grob *refp = gr->common_refpoint (o,  Axis (scm_to_int (axis)));
 326   return refp ? refp->self_scm () : SCM_BOOL_F;
 327 }
 328
 329 LY_DEFINE (ly_grob_common_refpoint_of_array, "ly:grob-common-refpoint-of-array",
 330            3, 0, 0,  (SCM grob, SCM others, SCM axis),
 331            "Find the common refpoint of @var{grob} and @var{others}"
 332            " (a grob-array) for @var{axis}.")
 333 {
 334   Grob *gr = unsmob_grob (grob);
 335
 336   LY_ASSERT_SMOB (Grob, grob, 1);
 337   LY_ASSERT_SMOB (Grob_array, others, 2);
 338
 339   Grob_array *ga = unsmob_grob_array (others);
 340   LY_ASSERT_TYPE (is_axis, axis, 3);
 341
 342   Grob *refp = common_refpoint_of_array (ga->array (), gr, Axis (scm_to_int (axis)));
 343   return refp ? refp->self_scm () : SCM_BOOL_F;
 344 }