lily/lily-guile.cc

   1 /*
   2   lily-guile.cc -- implement assorted guile functions
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   (c) 1998--1999 Jan Nieuwenhuizen <janneke@gnu.org>
   7
   8   Han-Wen Nienhuys <hanwen@cs.uu.nl>
   9 */
  10
  11 #include <stdio.h>
  12 #include "libc-extension.hh"
  13 #include "lily-guile.hh"
  14 #include "main.hh"
  15 #include "simple-file-storage.hh"
  16 #include "file-path.hh"
  17 #include "debug.hh"
  18
  19
  20 /*
  21   scm_m_quote doesn't use any env, but needs one for a good signature in GUILE.
  22
  23   Why there is no gh_quote () in GUILE  beats me.
  24 */
  25
  26 SCM
  27 ly_quote_scm (SCM s)
  28 {
  29   return scm_cons2 (scm_i_quote, s, SCM_EOL);
  30 }
  31
  32 /*
  33   See: libguile/symbols.c
  34
  35   SCM
  36   scm_string_to_symbol(s)
  37
  38 */
  39 SCM
  40 ly_symbol (String name)
  41 {
  42   return gh_car (scm_intern (name.ch_C(), name.length_i()));
  43 }
  44
  45 String
  46 symbol_to_string (SCM s)
  47 {
  48   return String((Byte*)SCM_CHARS (s), (int) SCM_LENGTH(s));
  49 }
  50
  51 SCM
  52 ly_set_scm (String name, SCM val)
  53 {
  54   return scm_sysintern (name.ch_C(), val);
  55
  56 }
  57 /**
  58
  59    Read a file, and shove it down GUILE.  GUILE also has file read
  60    functions, but you can't fiddle with the path of those.
  61
  62  */
  63 void
  64 read_lily_scm_file (String fn)
  65 {
  66   String s = global_path.find (fn);
  67   if (s == "")
  68     {
  69       String e = _f ("Can not find file `%s\'", fn);
  70       e += " ";
  71       e += _f ("(Load path is `%s\'", global_path.str ());
  72       error (e);
  73     }
  74   else
  75     *mlog << '[' << s;
  76
  77
  78   Simple_file_storage f(s);
  79
  80   gh_eval_str ((char *) f.ch_C());
  81   *mlog << ']' << flush;
  82 }
  83
  84
  85 void
  86 ly_display_scm (SCM s)
  87 {
  88   gh_display (s);
  89   gh_newline ();
  90 }
  91
  92 String
  93 ly_scm2string (SCM s)
  94 {
  95   int len;
  96   char * p = gh_scm2newstr (s , &len);
  97
  98   String r (p);
  99   delete p;
 100   return r;
 101 }
 102
 103 /*
 104   Layout of nodes:
 105
 106   (key . (left_child . right_child))
 107
 108   SCM_EOL is the nil-pointer (should use SCM_NIMP() ?)
 109  */
 110
 111 #define left_child(s) SCM_CADR((s))
 112 #define right_child(s) SCM_CDDR((s))
 113 #define key(s) SCM_CAR((s))
 114
 115 /*
 116   Garble pointers, to prevent unbalanced tree due to ordered inserts.
 117  */
 118
 119 unsigned int
 120 munge (SCM s)
 121 {
 122   const int SHIFT = 18;
 123   return (unsigned int)(s << (32-SHIFT) | s >> SHIFT );
 124 }
 125
 126 SCM
 127 ly_new_bintree_node (SCM val)
 128 {
 129   return gh_cons (val, gh_cons (SCM_EOL, SCM_EOL));
 130 }
 131
 132
 133 /*
 134   add VAL to TREE. TREE must be non-nil
 135  */
 136 void
 137 ly_addto_bintree (SCM *tree, SCM val)
 138 {
 139   while(*tree != SCM_EOL)
 140     {
 141       if (munge (val) <= munge (key (*tree)))
 142         tree = &left_child (*tree);
 143       else
 144         tree = &right_child (*tree);
 145     }
 146
 147   *tree = ly_new_bintree_node (val);
 148 }
 149
 150
 151 /*
 152   find the address of a node in the tree represented by *NODE with key VAL
 153  */
 154 SCM  *
 155 ly_find_in_bintree (SCM *node, SCM val)
 156 {
 157   while (*node != SCM_EOL)
 158     {
 159       if (munge (val) < munge (key(*node) ))
 160         node = &left_child(*node);
 161       else if (munge (val) > munge (key (*node)))
 162         node = &right_child (*node);
 163       else
 164         return node;
 165     }
 166   return node;
 167 }
 168
 169 void
 170 ly_remove_from_bintree (SCM *node)
 171 {
 172   SCM r = right_child  (*node);
 173   SCM l = left_child (*node);
 174
 175   if (r == SCM_EOL)
 176     {
 177       *node = l;
 178     }
 179   else if (l == SCM_EOL)
 180     {
 181       *node = r;
 182     }
 183   else
 184     {
 185       /*deleting from binary trees.  See Knuth's TAOCP.
 186        */
 187       SCM *t = node;
 188       SCM *left_t = &left_child (*t);
 189
 190       /*
 191         INV:  LEFT_T  is the left child of T
 192        */
 193       while (*left_t != SCM_EOL)
 194         {
 195           t = left_t;
 196           left_t = &left_child (*t);
 197         }
 198
 199       /*
 200         POST: T is the leftmost right child of NODE which has no left child,
 201
 202         leftchild (LASTT) == T
 203        */
 204       key(*node) = key(*t);
 205       *left_t = right_child (*t);
 206     }
 207 }
 208
 209
 210 static SCM protect_tree_root;
 211
 212 SCM
 213 ly_protect_scm (SCM s)
 214 {
 215   ly_addto_bintree (&protect_tree_root, s);
 216   return s;
 217 }
 218
 219 SCM
 220 ly_unprotect_scm (SCM s)
 221 {
 222   SCM *to_remove = ly_find_in_bintree (&protect_tree_root, s);
 223
 224   /*
 225     this shouldn't happen, according to me. But it does.
 226    */
 227   if (*to_remove != SCM_EOL)
 228     ly_remove_from_bintree (to_remove);
 229   return s;
 230 }
 231
 232 void
 233 ly_init_protection ()
 234 {
 235   protect_tree_root = scm_protect_object (ly_new_bintree_node(SCM_EOL));
 236   key (protect_tree_root) = protect_tree_root;
 237 }
 238
 239
 240 int
 241 ly_count_elements (SCM tree)
 242 {
 243   if (tree == SCM_EOL)
 244     return 0;
 245   else
 246     return 1 + ly_count_elements (left_child (tree)) + ly_count_elements (right_child( tree));
 247 }
 248
 249 int
 250 ly_tree_depth (SCM tree)
 251 {
 252   if (tree == SCM_EOL)
 253     return 0;
 254   else
 255     return 1 + (ly_tree_depth (left_child (tree)) >? ly_tree_depth (right_child(tree)));
 256 }
 257
 258 void
 259 ly_print_bintree (SCM node)
 260 {
 261 #ifndef NPRINT
 262   if (node == SCM_EOL)
 263     return;
 264   DOUT << "{val = " << key(node) << " \nleft = ";
 265   ly_print_bintree (left_child (node));
 266   DOUT << "\n right =";
 267   ly_print_bintree (right_child (node));
 268   DOUT << "}";
 269 #endif
 270 }
 271
 272
 273 struct Imbalance { int imbalance; int total; };
 274
 275 Imbalance
 276 ly_calc_imbalance (SCM node)
 277 {
 278   Imbalance t;
 279   if (node == SCM_EOL)
 280     {
 281       t.imbalance = 0;
 282       t.total = 0;
 283       return t;
 284     }
 285
 286   Imbalance l = ly_calc_imbalance (left_child (node));
 287   Imbalance r = ly_calc_imbalance (right_child (node));
 288
 289   t.total = l.total + r.total + 1;
 290   int dif = l.total - r.total;
 291   if (dif < 0)
 292      dif = -dif;
 293   t.imbalance = l.imbalance + r.imbalance + dif;
 294   return t;
 295 }