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 @var{g} of property @var{sym}. "
  50            "It will return @code{'()} or @var{deflt} (if specified) "
  51            "if  @var{sym} is undefined in @var{g}."
  52            "\n\n")
  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 @var{g} of property @var{sym}. "
  83            "It will return @code{' ()} (end-of-list) "
  84            "if  @var{sym} is undefined in @var{g}."
  85            "\n\n")
  86 {
  87   Grob *sc = unsmob_grob (grob);
  88
  89   LY_ASSERT_SMOB (Grob, grob, 1);
  90   LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
  91
  92   return sc->internal_get_object (sym);
  93 }
  94
  95
  96
  97 /* TODO: make difference between scaled and unscalead variable in
  98    calling (i.e different funcs.) */
  99 LY_DEFINE (ly_grob_layout, "ly:grob-layout",
 100            1, 0, 0, (SCM grob),
 101            "Get @code{\\layout} definition from grob @var{grob}.")
 102 {
 103   Grob *sc = unsmob_grob (grob);
 104
 105   LY_ASSERT_SMOB (Grob, grob, 1);
 106
 107   return sc->layout ()->self_scm ();
 108 }
 109
 110 LY_DEFINE (ly_grob_alist_chain, "ly:grob-alist-chain",
 111            1, 1, 0, (SCM grob, SCM global),
 112            "Get an alist chain for grob @var{grob}, with @var{global} as the "
 113            "global default. If unspecified, @code{font-defaults} "
 114            "from the layout block is taken. ")
 115 {
 116   Grob *sc = unsmob_grob (grob);
 117
 118   LY_ASSERT_SMOB (Grob, grob, 1);
 119
 120   if (global == SCM_UNDEFINED)
 121     {
 122       global = sc->layout ()->lookup_variable (ly_symbol2scm ("font-defaults"));
 123       if (global == SCM_UNDEFINED)
 124         global = SCM_EOL;
 125     }
 126
 127   return sc->get_property_alist_chain (global);
 128 }
 129
 130 LY_DEFINE (ly_grob_extent, "ly:grob-extent",
 131            3, 0, 0, (SCM grob, SCM refp, SCM axis),
 132            "Get the extent in @var{axis} direction of @var{grob} relative to "
 133            "the grob @var{refp}")
 134 {
 135   Grob *sc = unsmob_grob (grob);
 136   Grob *ref = unsmob_grob (refp);
 137
 138
 139   LY_ASSERT_SMOB (Grob, grob, 1);
 140   LY_ASSERT_SMOB (Grob, refp, 2);
 141   LY_ASSERT_TYPE (is_axis, axis, 3);
 142
 143   Axis a = Axis (scm_to_int (axis));
 144
 145
 146   if (ref->common_refpoint (sc, a) != ref)
 147     {
 148       // ugh. should use other error message
 149       SCM_ASSERT_TYPE (false, refp, SCM_ARG2, __FUNCTION__, "common refpoint");
 150     }
 151   return ly_interval2scm (sc->extent (ref, a));
 152 }
 153
 154 LY_DEFINE (ly_grob_robust_relative_extent, "ly:grob-robust-relative-extent",
 155            3, 0, 0, (SCM grob, SCM refp, SCM axis),
 156            "Get the extent in @var{axis} direction of @var{grob} relative to "
 157            "the grob @var{refp}, or (0,0) if empty")
 158 {
 159   Grob *sc = unsmob_grob (grob);
 160   Grob *ref = unsmob_grob (refp);
 161
 162
 163   LY_ASSERT_SMOB (Grob, grob, 1);
 164   LY_ASSERT_SMOB (Grob, refp, 2);
 165   LY_ASSERT_TYPE (is_axis, axis, 3);
 166
 167   Axis a = Axis (scm_to_int (axis));
 168
 169   if (ref->common_refpoint (sc, a) != ref)
 170     {
 171       // ugh. should use other error message
 172       SCM_ASSERT_TYPE (false, refp, SCM_ARG2, __FUNCTION__, "common refpoint");
 173     }
 174
 175   return ly_interval2scm (robust_relative_extent (sc, ref, a));
 176 }
 177
 178 LY_DEFINE (ly_grob_relative_coordinate, "ly:grob-relative-coordinate",
 179            3, 0, 0, (SCM grob, SCM refp, SCM axis),
 180            "Get the coordinate in @var{axis} direction of @var{grob} relative to "
 181            "the grob @var{refp}")
 182 {
 183   Grob *sc = unsmob_grob (grob);
 184   Grob *ref = unsmob_grob (refp);
 185
 186
 187   LY_ASSERT_SMOB (Grob, grob, 1);
 188   LY_ASSERT_SMOB (Grob, refp, 2);
 189   LY_ASSERT_TYPE (is_axis, axis, 3);
 190
 191   Axis a = Axis (scm_to_int (axis));
 192
 193
 194   if (ref->common_refpoint (sc, a) != ref)
 195     {
 196       // ugh. should use other error message
 197       SCM_ASSERT_TYPE (false, refp, SCM_ARG2, __FUNCTION__, "common refpoint");
 198     }
 199
 200   return scm_from_double (sc->relative_coordinate (ref, a));
 201 }
 202
 203
 204 LY_DEFINE (ly_grob_parent, "ly:grob-parent",
 205            2, 0, 0, (SCM grob, SCM axis),
 206            "Get the parent of @var{grob}.  @var{axis} is 0 for the X-axis, "
 207            "1 for the Y-axis.")
 208 {
 209   Grob *sc = unsmob_grob (grob);
 210
 211   LY_ASSERT_SMOB (Grob, grob, 1);
 212   LY_ASSERT_TYPE (is_axis, axis, 2);
 213
 214   Grob *par = sc->get_parent (Axis (scm_to_int (axis)));
 215   return par ? par->self_scm () : SCM_EOL;
 216 }
 217
 218 LY_DEFINE (ly_grob_properties, "ly:grob-properties",
 219            1, 0, 0, (SCM grob),
 220            "Get the mutable proprerties of @var{grob}.")
 221 {
 222   Grob *g = unsmob_grob (grob);
 223
 224   LY_ASSERT_SMOB (Grob, grob, 1);
 225
 226   /* FIXME: uhg? copy/read only? */
 227   return g->mutable_property_alist_;
 228 }
 229
 230 LY_DEFINE (ly_grob_basic_properties, "ly:grob-basic-properties",
 231            1, 0, 0, (SCM grob),
 232            "Get the immutable properties of @var{grob}.")
 233 {
 234   Grob *g = unsmob_grob (grob);
 235
 236   LY_ASSERT_SMOB (Grob, grob, 1);
 237
 238   /* FIXME: uhg? copy/read only? */
 239   return g->immutable_property_alist_;
 240 }
 241
 242 LY_DEFINE (ly_grob_system, "ly:grob-system",
 243            1, 0, 0, (SCM grob),
 244            "Return the System Grob of @var{grob}.")
 245 {
 246   Grob *me = unsmob_grob (grob);
 247
 248   LY_ASSERT_SMOB (Grob, grob, 1);
 249
 250   if (System *g = me->get_system ())
 251     return g->self_scm ();
 252
 253   return SCM_EOL;
 254 }
 255
 256 LY_DEFINE (ly_grob_original, "ly:grob-original",
 257            1, 0, 0, (SCM grob),
 258            "Return the unbroken original Grob of @var{grob}.")
 259 {
 260   Grob *me = unsmob_grob (grob);
 261
 262   LY_ASSERT_SMOB (Grob, grob, 1);
 263   return me->original () ? me->original ()->self_scm () : me->self_scm ();
 264 }
 265
 266
 267 LY_DEFINE (ly_grob_suicide_x, "ly:grob-suicide!",
 268            1, 0, 0, (SCM grob),
 269            "Kill @var{grob}.")
 270 {
 271   Grob *me = unsmob_grob (grob);
 272
 273   LY_ASSERT_SMOB (Grob, grob, 1);
 274
 275   me->suicide ();
 276   return SCM_UNSPECIFIED;
 277 }
 278
 279 LY_DEFINE (ly_grob_translate_axis_x, "ly:grob-translate-axis!",
 280            3, 0, 0, (SCM grob, SCM d, SCM a),
 281            "Translate @var{g} on axis @var{a} over distance @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} for @var{axis}."
 313            )
 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 {
 335   Grob *gr = unsmob_grob (grob);
 336
 337   LY_ASSERT_SMOB (Grob, grob, 1);
 338   LY_ASSERT_SMOB (Grob_array, others, 2);
 339
 340   Grob_array *ga = unsmob_grob_array (others);
 341   LY_ASSERT_TYPE (is_axis, axis, 3);
 342
 343   Grob *refp = common_refpoint_of_array (ga->array (), gr, Axis (scm_to_int (axis)));
 344   return refp ? refp->self_scm () : SCM_BOOL_F;
 345 }