lily/nested-property.cc

   1 #include "context.hh"
   2 #include "grob.hh"
   3
   4 // scm_reverse_x without the checks
   5 SCM
   6 fast_reverse_x (SCM lst, SCM tail)
   7 {
   8   while (!scm_is_null (lst))
   9     {
  10       SCM n = scm_cdr (lst);
  11       scm_set_cdr_x (lst, tail);
  12       tail = lst;
  13       lst = n;
  14     }
  15   return tail;
  16 }
  17
  18 // copy the spine of lst not including tail, appending newtail
  19 // returns new list.
  20 SCM
  21 partial_list_copy (SCM lst, SCM tail, SCM newtail)
  22 {
  23   SCM p = SCM_EOL;
  24   for (; !scm_is_eq (lst, tail); lst = scm_cdr (lst))
  25     p = scm_cons (scm_car (lst), p);
  26   return fast_reverse_x (p, newtail);
  27 }
  28
  29 SCM
  30 assq_tail (SCM key, SCM alist, SCM based_on = SCM_EOL)
  31 {
  32   for (SCM p = alist; !scm_is_eq (p, based_on); p = scm_cdr (p))
  33     {
  34       if (scm_is_eq (scm_caar (p), key))
  35         return p;
  36     }
  37   return SCM_BOOL_F;
  38 }
  39
  40 SCM
  41 assv_tail (SCM key, SCM alist, SCM based_on = SCM_EOL)
  42 {
  43   for (SCM p = alist; !scm_is_eq (p, based_on); p = scm_cdr (p))
  44     {
  45       if (scm_is_true (scm_eqv_p (scm_caar (p), key)))
  46         return p;
  47     }
  48   return SCM_BOOL_F;
  49 }
  50
  51 SCM
  52 assoc_tail (SCM key, SCM alist, SCM based_on = SCM_EOL)
  53 {
  54   if (SCM_IMP (key))
  55     return assq_tail (key, alist, based_on);
  56   if (scm_is_number (key) || scm_is_true (scm_char_p (key)))
  57     return assv_tail (key, alist, based_on);
  58   for (SCM p = alist; !scm_is_eq (p, based_on); p = scm_cdr (p))
  59     {
  60       if (ly_is_equal (scm_caar (p), key))
  61         return p;
  62     }
  63   return SCM_BOOL_F;
  64 }
  65
  66 // Like assq, but removes the found element destructively
  67 SCM assq_pop_x (SCM key, SCM *alist)
  68 {
  69   for (SCM p = *alist; scm_is_pair (p); p = *(alist = SCM_CDRLOC (p)))
  70     {
  71       if (scm_is_eq (scm_caar (p), key))
  72         {
  73           *alist = scm_cdr (p);
  74           return scm_car (p);
  75         }
  76     }
  77   return SCM_BOOL_F;
  78 }
  79
  80 /*
  81   Drop key from the list alist..alist_end.
  82  */
  83 SCM
  84 evict_from_alist (SCM key, SCM alist, SCM alist_end)
  85 {
  86   SCM p = assoc_tail (key, alist, alist_end);
  87
  88   if (scm_is_true (p))
  89     return partial_list_copy (alist, p, scm_cdr (p));
  90   return alist;
  91 }
  92
  93 // This is the same as
  94 // nested_property_alist (SCM_EOL, prop_path, value) but faster
  95 SCM
  96 nested_create_alist (SCM prop_path, SCM value)
  97 {
  98   if (scm_is_null (prop_path))
  99     return value;
 100   return scm_acons (scm_car (prop_path),
 101                     nested_create_alist (scm_cdr (prop_path), value),
 102                     SCM_EOL);
 103 }
 104
 105 /*
 106   PROP_PATH should be big-to-small ordering
 107  */
 108
 109 // Take the given alist and replace the given nested property with the
 110 // given value.  Multiple overrides of the same property path are not
 111 // coalesced for efficiency reasons: they are considered rare enough
 112 // to not be worth the cost of detecting them.  When sublists are
 113 // modified, however, we remove the original sublist and copy the
 114 // spine before it.  The cost for finding the sublist has already been
 115 // paid anyway.
 116
 117 // A typical use case for this routine is applying (possibly nested)
 118 // tweaks to a grob property list.
 119
 120 SCM
 121 nested_property_alist (SCM alist, SCM prop_path, SCM value)
 122 {
 123   // replacement moves to the front.
 124   SCM key = scm_car (prop_path);
 125   SCM rest = scm_cdr (prop_path);
 126   if (scm_is_pair (rest))
 127     {
 128       SCM where = assoc_tail (key, alist);
 129
 130       if (scm_is_false (where))
 131         return scm_acons (key, nested_create_alist (rest, value), alist);
 132       return scm_acons (key, nested_property_alist (scm_cdar (where),
 133                                                     rest,
 134                                                     value),
 135                         partial_list_copy (alist, where, scm_cdr (where)));
 136     }
 137   // Outcommented code would coalesce multiple overrides of the same
 138   // property
 139 #if 0
 140   SCM where = assq_tail (alist, key);
 141   if (scm_is_true (where))
 142     return scm_acons (key, value,
 143                       partial_list_copy (alist, where, scm_cdr (where)));
 144 #endif
 145   return scm_acons (key, value, alist);
 146 }
 147
 148 SCM
 149 nested_property (SCM alist, SCM prop_path, SCM fallback)
 150 {
 151   for (; scm_is_pair (prop_path); prop_path = scm_cdr (prop_path))
 152     {
 153       SCM tail = assoc_tail (scm_car (prop_path), alist);
 154       if (scm_is_false (tail))
 155         return fallback;
 156       alist = scm_cdar (tail);
 157     }
 158   return alist;
 159 }
 160
 161 void
 162 set_nested_property (Grob *me, SCM big_to_small, SCM value)
 163 {
 164   SCM alist = me->get_property (scm_car (big_to_small));
 165
 166   alist = nested_property_alist (alist, scm_cdr (big_to_small), value);
 167
 168   me->set_property (scm_car (big_to_small), alist);
 169 }
 170
 171 // This converts an alist with nested overrides in it to a proper
 172 // alist.  The number of nested overrides is known in advance,
 173 // everything up to the last nested override is copied, the tail is
 174 // shared.
 175 //
 176 // The first nalist index has to be a symbol since the conversion
 177 // relies on eq? comparisons, uses some special non-symbol values for
 178 // special purposes, and does validity checking indexed by symbols.
 179 // Subindexing can be done with equal?-comparable indexes, however.
 180
 181 SCM
 182 nalist_to_alist (SCM nalist, int nested)
 183 {
 184   if (!nested)
 185     return nalist;
 186   SCM copied = SCM_EOL;
 187   SCM partials = SCM_EOL;
 188   // partials is a alist of partial overrides
 189   while (nested)
 190     {
 191       SCM elt = scm_car (nalist);
 192       nalist = scm_cdr (nalist);
 193       SCM key = scm_car (elt);
 194       if (!scm_is_symbol (key))
 195         --nested;
 196       if (scm_is_bool (key))
 197         {
 198           if (scm_is_false (key))
 199             continue;
 200           elt = scm_cdr (elt);
 201           key = scm_car (elt);
 202         }
 203       if (scm_is_pair (key))
 204         // nested override: record for key in partial
 205         {
 206           SCM pair = scm_sloppy_assq (scm_car (key), partials);
 207           if (scm_is_false (pair))
 208             partials = scm_acons (scm_car (key), scm_list_1 (elt),
 209                                   partials);
 210           else
 211             scm_set_cdr_x (pair, scm_cons (elt, scm_cdr (pair)));
 212           continue;
 213         }
 214       assert (scm_is_symbol (key));
 215       // plain override: apply any known corresponding partials
 216       SCM pair = assq_pop_x (key, &partials);
 217       if (scm_is_true (pair))
 218         {
 219           SCM value = scm_cdr (elt);
 220           for (SCM pp = scm_cdr (pair); scm_is_pair (pp); pp = scm_cdr (pp))
 221             value = nested_property_alist (value, scm_cdaar (pp), scm_cdar (pp));
 222           copied = scm_acons (key, value, copied);
 223         }
 224       else
 225         copied = scm_cons (elt, copied);
 226     }
 227   // Now need to work off the remaining partials.  All of them are
 228   // unique, so we can push them to `copied' after resolving without
 229   // losing information.
 230
 231   for (;scm_is_pair (partials); partials = scm_cdr (partials))
 232     {
 233       SCM pair = scm_car (partials);
 234       SCM key = scm_car (pair);
 235       SCM elt = scm_sloppy_assq (key, nalist);
 236       SCM value = SCM_EOL;
 237       if (scm_is_true (elt))
 238         value = scm_cdr (elt);
 239
 240       for (SCM pp = scm_cdr (pair); scm_is_pair (pp); pp = scm_cdr (pp))
 241         value = nested_property_alist (value, scm_cdaar (pp), scm_cdar (pp));
 242
 243       copied = scm_acons (key, value, copied);
 244     }
 245   return fast_reverse_x (copied, nalist);
 246 }
 247
 248 #if 0
 249 // Alternative approach: don't unfold those partial overrides while
 250 // they are part of contexts but instead use a special accessor for
 251 // subproperties in the grob.  Not used or tested for now.
 252
 253 SCM
 254 nassq_ref (SCM key, SCM nalist, SCM fallback)
 255 {
 256   SCM partials = SCM_EOL;
 257   // partials is list of partial overrides for the given property
 258   for (SCM p = nalist; scm_is_pair (p); p = scm_cdr (p))
 259     {
 260       SCM elt = scm_car (p);
 261       SCM pkey = scm_car (elt);
 262       if (scm_is_pair (pkey))
 263         {
 264           if (scm_is_eq (scm_car (pkey), key))
 265             partials = scm_cons (elt, partials);
 266         }
 267       else if (scm_is_eq (pkey, key))
 268         {
 269           SCM value = scm_cdr (elt);
 270           for (; scm_is_pair (partials); partials = scm_cdr (partials))
 271             {
 272               value = nested_property_alist (value, scm_cdaar (partials),
 273                                             scm_cdar (partials));
 274             }
 275           return value;
 276         }
 277     }
 278   if (scm_is_pair (partials))
 279     {
 280       // Bit of a quandary here: we have only subproperty overrides
 281       // but no main property.  Could be a programming error, but we
 282       // instead override an empty list.
 283       SCM value = nested_create_alist (scm_cdaar (partials), scm_cdar (partials));
 284       partials = scm_cdr (partials);
 285       for (; scm_is_pair (partials); partials = scm_cdr (partials))
 286         value = nested_property_alist (value, scm_cdaar (partials),
 287                                       scm_cdar (partials));
 288       return value;
 289     }
 290   return SCM_UNBNDP (fallback) ? SCM_EOL : fallback;
 291 }
 292
 293 // Also needed for this approach to make sense: an accessor for true
 294 // subproperties.
 295 SCM
 296 nassq_nested_ref (SCM key, SCM subpath, SCM nalist, SCM fallback);
 297 // To be implemented
 298
 299 #endif