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