release: 1.3.105

[lilypond.git] / lily / font-interface.cc

diff --git a/lily/font-interface.cc b/lily/font-interface.cc
index dc6bd81d57117680f793c74021d18815d90095b1..452a956ee693e4c058d438264b67b94998d57ce2 100644 (file)
--- a/lily/font-interface.cc
+++ b/lily/font-interface.cc
@@ -12,6 +12,7 @@
 #include "font-interface.hh"
 #include "score-element.hh"
 #include "paper-def.hh"
+#include "warn.hh"
 
 
 SCM
@@ -77,3 +78,127 @@ Font_interface::add_style (Score_element* me, SCM style, SCM chain)
     }
   return chain;
 }
+
+/*
+SCM routines:  
+
+Interpreting music...
+MIDI output to wtk1-fugue2.midi...
+Track ... 
+
+real   0m31.862s
+user   0m29.110s
+sys    0m0.260s
+
+real   0m26.964s
+user   0m24.850s
+sys    0m0.280s
+
+
+so a 14% speedup.
+
+*/
+
+static SCM name_sym, shape_sym, family_sym, series_sym, rel_sz_sym, pt_sz_sym;
+
+
+static void
+init_syms ()
+{
+  name_sym = scm_permanent_object (ly_symbol2scm ("font-name"));
+  shape_sym  = scm_permanent_object (ly_symbol2scm ("font-shape"));
+  family_sym = scm_permanent_object (ly_symbol2scm ("font-family"));
+  series_sym = scm_permanent_object (ly_symbol2scm ("font-series"));
+  rel_sz_sym = scm_permanent_object (ly_symbol2scm ("font-relative-size"));
+  pt_sz_sym = scm_permanent_object (ly_symbol2scm ("font-point-size"));
+}
+
+
+ADD_SCM_INIT_FUNC(Font_interface_syms,init_syms);
+
+
+MAKE_SCHEME_CALLBACK(Font_interface,properties_to_font_name,2);
+SCM
+Font_interface::properties_to_font_name (SCM fonts, SCM alist_chain)
+{
+  SCM name = ly_assoc_chain (name_sym, alist_chain);
+
+  SCM shape = SCM_BOOL_F;
+  SCM family = SCM_BOOL_F;
+  SCM series = SCM_BOOL_F;
+
+  
+  SCM point_sz = ly_assoc_chain (pt_sz_sym, alist_chain);
+  SCM rel_sz = SCM_BOOL_F;
+
+  if (!gh_pair_p (name))
+    {
+       shape = ly_assoc_chain (shape_sym, alist_chain);
+       family = ly_assoc_chain (family_sym, alist_chain);
+       series = ly_assoc_chain (series_sym, alist_chain);
+
+       if (gh_pair_p (shape))
+        shape = gh_cdr (shape);
+       if (gh_pair_p (family))
+        family = gh_cdr (family);
+       if (gh_pair_p (series))
+        series = gh_cdr (series);
+    }
+  else
+    name = gh_cdr (name);
+
+
+  if (gh_pair_p (point_sz))
+    point_sz = gh_cdr (point_sz);
+  else
+    {
+      rel_sz = ly_assoc_chain (rel_sz_sym, alist_chain);
+      if (gh_pair_p (rel_sz))
+       rel_sz = gh_cdr (rel_sz);
+    }
+
+  for (SCM s = fonts ; gh_pair_p (s); s = gh_cdr (s))
+    {
+      SCM qlist = gh_caar (s);
+
+      if (name != SCM_BOOL_F)
+       {
+         if (scm_list_ref (qlist, gh_int2scm (4)) != name)
+           continue;
+       }
+      else
+       {
+         if (series != SCM_BOOL_F
+             && scm_list_ref (qlist, gh_int2scm (1)) != series)
+           continue;
+         if (shape != SCM_BOOL_F
+             && scm_list_ref (qlist, gh_int2scm (2)) != shape)
+           continue;
+         if (family != SCM_BOOL_F
+             && scm_list_ref (qlist, gh_int2scm (3)) != family)
+           continue;
+       }
+  
+      if (point_sz != SCM_BOOL_F)
+       {
+         if (scm_list_ref (qlist, gh_int2scm (4)) != name)
+           continue;
+       }
+      else
+       {
+         if (rel_sz != SCM_BOOL_F
+             && gh_car (qlist) != rel_sz)
+           continue;
+       }
+
+      
+      SCM qname = gh_cdar (s);
+      return qname;
+    }
+
+  warning (_("couldn't find any font satisfying ") );
+  scm_write (gh_list (name, point_sz, shape, series , family, rel_sz, SCM_UNDEFINED), scm_current_error_port ());
+
+  return gh_str02scm ("cmr10");
+  
+}