object key dumper/undumper.
Can't use make_spanner_from_properties() because we have to use
beam_settings_.
*/
- Spanner *beam = new Spanner (beam_settings_,
- context ()->get_grob_key ("Beam"));
+ Spanner *beam = new Spanner (beam_settings_, 0);
for (vsize i = 0; i < stems_->size (); i++)
Beam::add_stem (beam, (*stems_)[i]);
+++ /dev/null
-/*
- context-key-manager.cc -- implement Context_key_manager
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2006--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-
-*/
-
-#include "context-key-manager.hh"
-#include "object-key.hh"
-#include "lilypond-key.hh"
-#include "main.hh"
-
-Context_key_manager::Context_key_manager (Object_key const *key)
-{
- key_ = key;
-}
-
-void
-Context_key_manager::unprotect () const
-{
- if (key_)
- ((Object_key *)key_)->unprotect ();
-}
-
-
-Object_key const *
-Context_key_manager::get_context_key (Moment now, string type, string id)
-{
- if (!use_object_keys)
- return 0;
-
- string now_key = type + "@" + id;
-
- int disambiguation_count = 0;
- if (context_counts_.find (now_key) != context_counts_.end ())
- disambiguation_count = context_counts_[now_key];
-
- context_counts_[now_key] = disambiguation_count + 1;
-
- return new Lilypond_context_key (key (),
- now,
- type, id,
- disambiguation_count);
-}
-
-
-Object_key const *
-Context_key_manager::get_grob_key (Moment m, string name)
-{
- if (!use_object_keys)
- return 0;
-
- return create_grob_key (m, name);
-}
-
-/*
- We want to have a key for some objects anyway, so we can invent a
- unique identifier for each (book,score) tuple.
-*/
-Object_key const *
-Context_key_manager::create_grob_key (Moment now, string name)
-{
- int disambiguation_count = 0;
- if (grob_counts_.find (name) != grob_counts_.end ())
- disambiguation_count = grob_counts_[name];
- grob_counts_[name] = disambiguation_count + 1;
-
- Object_key *k = new Lilypond_grob_key (key (),
- now,
- name,
- disambiguation_count);
-
- return k;
-}
-
-void
-Context_key_manager::gc_mark () const
-{
- if (key_)
- scm_gc_mark (key_->self_scm ());
-
-}
-
-void
-Context_key_manager::clear ()
-{
- if (!use_object_keys)
- return;
-
- grob_counts_.clear ();
- context_counts_.clear ();
-}
-
-Context_key_manager::Context_key_manager (Context_key_manager const &src)
-{
- (void)src;
- assert (false);
-}
}
Context::Context (Context const &src)
- : key_manager_ (src.key_manager_)
{
assert (false);
}
Context::Context (Object_key const *key)
- : key_manager_ (key)
{
daddy_context_ = 0;
aliases_ = SCM_EOL;
event_source_->unprotect ();
events_below_ = new Dispatcher ();
events_below_->unprotect ();
-
- /*
- UGH UGH
- const correctness.
- */
- key_manager_.unprotect();
}
/* TODO: this shares code with find_create_context (). */
SCM ops = ev->get_property ("ops");
SCM type_scm = ev->get_property ("type");
string type = ly_symbol2string (type_scm);
- Object_key const *key = key_manager_.get_context_key (now_mom(), type, id);
+ Object_key const *key = 0;
vector<Context_def*> path
= unsmob_context_def (definition_)->path_to_acceptable_context (type_scm, get_output_def ());
return 1;
}
-Object_key const *
-Context::get_grob_key (string name)
-{
- return key_manager_.get_grob_key (now_mom (), name);
-}
-
-Object_key const *
-Context::get_context_key (string name, string id)
-{
- return key_manager_.get_context_key (now_mom (), name, id);
-}
-
SCM
Context::mark_smob (SCM sm)
{
Context *me = (Context *) SCM_CELL_WORD_1 (sm);
- me->key_manager_.gc_mark();
scm_gc_mark (me->context_list_);
scm_gc_mark (me->aliases_);
return daddy_context_;
}
-void
-Context::clear_key_disambiguations ()
-{
- if (!use_object_keys)
- return;
-
- key_manager_.clear ();
- for (SCM s = context_list_; scm_is_pair (s); s = scm_cdr (s))
- unsmob_context (scm_car (s))->clear_key_disambiguations ();
-}
-
/*
Ugh. Where to put this?
*/
SCM props = updated_grob_properties (context (), symbol);
- Object_key const *key = context ()->get_grob_key (name);
+ Object_key const *key = 0;
Grob *grob = 0;
SCM handle = scm_sloppy_assq (ly_symbol2scm ("meta"), props);
else
prev_mom_ = now_mom_;
now_mom_ = *mom;
-
- clear_key_disambiguations ();
}
Moment
Grob::Grob (Grob const &s, int copy_index)
: dim_cache_ (s.dim_cache_)
{
- key_ = (use_object_keys) ? new Copied_key (s.key_, copy_index) : 0;
+ key_ = 0; // (use_object_keys) ? new Copied_key (s.key_, copy_index) : 0;
original_ = (Grob *) & s;
self_scm_ = SCM_EOL;
+++ /dev/null
-/*
- context-key-manager.hh -- declare Context_key_manager
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2006--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-
-*/
-
-#ifndef CONTEXT_KEY_MANAGER_HH
-#define CONTEXT_KEY_MANAGER_HH
-
-#include "lily-proto.hh"
-
-#include <map>
-using namespace std;
-
-class Context_key_manager
-{
- Object_key const *key_;
- map<string, int> grob_counts_;
- map<string, int> context_counts_;
-
-
-protected:
- friend class Context;
-
- Context_key_manager (Object_key const *);
- Context_key_manager (Context_key_manager const &src);
-
-
- void unprotect () const;
- void gc_mark () const;
- void clear ();
- Object_key const *key () const { return key_; }
- Object_key const *create_grob_key (Moment, string);
- Object_key const *get_grob_key (Moment, string);
- Object_key const *get_context_key (Moment, string, string);
-};
-
-#endif /* CONTEXT_KEY_MANAGER_HH */
-
-
#ifndef CONTEXT_HH
#define CONTEXT_HH
-#include "context-key-manager.hh"
#include "listener.hh"
#include "moment.hh"
#include "std-vector.hh"
#include "virtual-methods.hh"
+#include "scm-hash.hh"
+#include "lily-proto.hh"
class Context
{
SCM definition_;
/* Additions to the Context_def, given by \with */
SCM definition_mods_;
- Context_key_manager key_manager_;
+ // Context_key_manager key_manager_;
SCM properties_scm_;
SCM context_list_;
+++ /dev/null
-/*
- object-key-dumper.hh -- declare Object_key_dumper
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#ifndef OBJECT_KEY_DUMPER_HH
-#define OBJECT_KEY_DUMPER_HH
-
-#include <map>
-using namespace std;
-
-#include "object-key.hh"
-
-typedef map<Object_key const *, Object_key const *, Object_key_less> Key_to_key_map;
-typedef map<Object_key const *, int> Pointer_to_int_map;
-typedef map<int, Object_key const *> Int_to_key_map;
-
-class Object_key_dumper
-{
- SCM file_contents_;
- Key_to_key_map serialized_keys_;
- Pointer_to_int_map key_serial_numbers_;
- int next_available_;
-
- SCM key_serial (int);
- SCM serialize_key (Object_key const *);
- DECLARE_SMOBS (Object_key_dumper);
-public:
- Object_key_dumper ();
- SCM get_file_contents () const;
- SCM dump_key (Object_key const *);
-};
-
-DECLARE_UNSMOB (Object_key_dumper, key_dumper);
-
-#endif /* OBJECT_KEY_DUMPER_HH */
-
+++ /dev/null
-/*
- object-key-undumper.hh -- declare Object_key_undumper
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#ifndef OBJECT_KEY_UNDUMPER_HH
-#define OBJECT_KEY_UNDUMPER_HH
-
-#include <map>
-using namespace std;
-
-#include "object-key.hh"
-
-typedef map<int, Object_key const *> Int_to_key_map;
-
-struct Object_key_undumper
-{
- DECLARE_SMOBS (Object_key_undumper);
- Int_to_key_map keys_;
-public:
- void parse_contents (SCM);
- Object_key_undumper ();
- Object_key const *get_key (int k);
-};
-DECLARE_UNSMOB (Object_key_undumper, key_undumper);
-
-#endif
using namespace std;
#include "lily-proto.hh"
-#include "object-key.hh"
typedef map<Object_key const *, SCM, Object_key_less> Tweak_map;
ly_c_init_guile ();
call_constructors ();
- init_global_tweak_registry ();
init_fontconfig ();
init_freetype ();
+++ /dev/null
-/*
- object-key-dumper-scheme.cc -- implement Object_key_dumper bindings
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2005--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#include "object-key-dumper.hh"
-
-#include "moment.hh"
-
-LY_DEFINE (ly_make_dumper, "ly:make-dumper",
- 0, 0, 0,
- (),
- "Create a key dumper. ")
-{
- Object_key_dumper *u = new Object_key_dumper ();
- return u->unprotect ();
-}
-
-LY_DEFINE (ly_dumper_definitions, "ly:dumper-definitions",
- 1, 0, 0,
- (SCM dumper),
- "Return list of key definitions. ")
-{
- Object_key_dumper *u = unsmob_key_dumper (dumper);
- SCM_ASSERT_TYPE (u, dumper, SCM_ARG1, __FUNCTION__, "dumper");
- return u->get_file_contents ();
-}
-
-LY_DEFINE (ly_dumper_key_serial, "ly:dumper-key-serial",
- 2, 0, 0,
- (SCM dumper, SCM key),
- "Return the key serial number @var{key}. ")
-{
- Object_key_dumper *u = unsmob_key_dumper (dumper);
- Object_key *k = unsmob_key (key);
- SCM_ASSERT_TYPE (u, dumper, SCM_ARG1, __FUNCTION__, "dumper");
- SCM_ASSERT_TYPE (k, key, SCM_ARG2, __FUNCTION__, "key");
- return u->dump_key (k);
-}
+++ /dev/null
-/*
- object-key-dumper.cc -- implement Object_key_dumper
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#include "object-key-dumper.hh"
-
-#include "moment.hh"
-
-#include "ly-smobs.icc"
-
-SCM
-Object_key_dumper::mark_smob (SCM smob)
-{
- Object_key_dumper *dumper = (Object_key_dumper *) SCM_CELL_WORD_1 (smob);
-
- for (Key_to_key_map::const_iterator i (dumper->serialized_keys_.begin ());
- i != dumper->serialized_keys_.end ();
- i++)
- scm_gc_mark ((*i).first->self_scm ());
- return SCM_EOL;
-}
-
-int
-Object_key_dumper::print_smob (SCM, SCM port, scm_print_state*)
-{
- scm_puts ("#<Object_key_dumper>", port);
- return 1;
-}
-
-IMPLEMENT_DEFAULT_EQUAL_P (Object_key_dumper);
-IMPLEMENT_SMOBS (Object_key_dumper);
-
-Object_key_dumper::Object_key_dumper ()
-{
- file_contents_ = SCM_EOL;
- next_available_ = 0;
- smobify_self ();
-}
-
-SCM
-Object_key_dumper::key_serial (int k)
-{
- return scm_list_2 (ly_symbol2scm ("key"),
- scm_from_int (k));
-}
-
-SCM
-Object_key_dumper::serialize_key (Object_key const *key)
-{
- SCM skey = key->dump ();
- for (SCM s = skey; scm_is_pair (s); s = scm_cdr (s))
- {
- if (Object_key const *sub_key = unsmob_key (scm_car (s)))
- scm_set_car_x (s, dump_key (sub_key));
- else if (Moment *mom = unsmob_moment (scm_car (s)))
- scm_set_car_x (s,
- scm_list_2 (ly_symbol2scm ("unquote"),
- mom->as_scheme ()));
- }
-
- file_contents_ = scm_cons (scm_list_3 (ly_symbol2scm ("define-key"),
- scm_from_int (next_available_),
- skey),
- file_contents_);
-
- serialized_keys_[key] = key;
- key_serial_numbers_[key] = next_available_;
- SCM retval = key_serial (next_available_);
- next_available_++;
-
- return retval;
-}
-
-SCM
-Object_key_dumper::dump_key (Object_key const *key)
-{
- if (key_serial_numbers_.find (key) != key_serial_numbers_.end ())
- return key_serial (key_serial_numbers_[key]);
- else if (Object_key const *serialized = serialized_keys_[key])
- return key_serial (key_serial_numbers_[ serialized_keys_ [serialized] ]);
-
- return serialize_key (key);
-}
-
-SCM
-Object_key_dumper::get_file_contents () const
-{
- return scm_reverse (file_contents_);
-}
-
-Object_key_dumper::~Object_key_dumper ()
-{
-}
+++ /dev/null
-/*
- object-key-undumper-scheme.cc -- implement Object_key_undumper bindings
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2005--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#include "object-key-undumper.hh"
-
-LY_DEFINE (ly_undumper_read_keys, "ly:undumper-read-keys",
- 2, 0, 0,
- (SCM undumper, SCM keys),
- "Read serialized @var{keys} into @var{undumper}.")
-{
- Object_key_undumper *u = unsmob_key_undumper (undumper);
- SCM_ASSERT_TYPE (u, undumper, SCM_ARG1, __FUNCTION__, "Undumper");
-
- u->parse_contents (keys);
- return SCM_UNSPECIFIED;
-}
-
-LY_DEFINE (ly_make_undumper, "ly:make-undumper",
- 0, 0, 0,
- (),
- "Create a key undumper. ")
-{
- Object_key_undumper *u = new Object_key_undumper ();
- return u->unprotect ();
-}
-
-LY_DEFINE (ly_undumper_lookup, "ly:undumper-lookup",
- 2, 0, 0,
- (SCM undumper, SCM serial),
- "Return the object key for number @var{serial}. ")
-
-{
- Object_key_undumper *u = unsmob_key_undumper (undumper);
-
- SCM_ASSERT_TYPE (u, undumper, SCM_ARG1, __FUNCTION__, "undumper");
- SCM_ASSERT_TYPE (scm_is_integer (serial), serial, SCM_ARG2, __FUNCTION__, "integer");
- return u->get_key (scm_to_int (serial))->self_scm ();
-}
-
+++ /dev/null
-/*
- object-key-undumper.cc -- implement Object_key_undumper
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#include "object-key-undumper.hh"
-
-#include "ly-smobs.icc"
-
-IMPLEMENT_SMOBS (Object_key_undumper);
-IMPLEMENT_DEFAULT_EQUAL_P (Object_key_undumper);
-
-SCM
-Object_key_undumper::mark_smob (SCM smob)
-{
- Object_key_undumper *undumper = (Object_key_undumper *) SCM_CELL_WORD_1 (smob);
- for (Int_to_key_map::const_iterator i (undumper->keys_.begin ());
- i != undumper->keys_.end (); i++)
- scm_gc_mark ((*i).second->self_scm ());
-
- return SCM_BOOL_F;
-}
-
-int
-Object_key_undumper::print_smob (SCM s, SCM port, scm_print_state*)
-{
- (void) s;
- scm_puts ("#<Object_key_undumper>", port);
- return 1;
-}
-
-Object_key_undumper::Object_key_undumper ()
-{
- smobify_self ();
-}
-
-void
-Object_key_undumper::parse_contents (SCM contents)
-{
- for (SCM s = contents; scm_is_pair (s); s = scm_cdr (s))
- {
- SCM entry = scm_car (s);
- if (scm_car (entry) != ly_symbol2scm ("define-key"))
- continue;
-
- int number = scm_to_int (scm_cadr (entry));
- SCM skey = scm_caddr (entry);
-
- SCM new_key = SCM_EOL;
- SCM *tail = &new_key;
- for (SCM t = skey; scm_is_pair (t); t = scm_cdr (t))
- {
- SCM item = scm_car (t);
- if (scm_is_pair (item)
- && scm_car (item) == ly_symbol2scm ("key"))
- {
- int index = scm_to_int (scm_cadr (item));
- Object_key const *key = get_key (index);
- *tail = scm_cons (key->self_scm (), SCM_EOL);
- }
- else
- *tail = scm_cons (item, SCM_EOL);
- tail = SCM_CDRLOC (*tail);
- }
-
- Object_key *k = Object_key::undump (new_key);
- keys_[number] = k;
- k->unprotect ();
- }
-}
-
-Object_key const *
-Object_key_undumper::get_key (int idx)
-{
- Int_to_key_map::const_iterator i (keys_.find (idx));
- assert (i != keys_.end ());
-
- return (*i).second;
-}
-
-Object_key_undumper::~Object_key_undumper ()
-{
-}
*/
#include "program-option.hh"
-#include "profile.hh"
#include <cstdio>
#include <cstring>
using namespace std;
+#include "profile.hh"
#include "international.hh"
#include "main.hh"
#include "parse-scm.hh"
/* Write midi as formatted ascii stream? */
bool do_midi_debugging_global;
-bool use_object_keys;
bool debug_skylines;
/*
lily_1_8_compatibility_used = to_boolean (val);
val = scm_from_bool (to_boolean (val));
}
- else if (var == ly_symbol2scm ("object-keys"))
- {
- use_object_keys = to_boolean (val);
- val = scm_from_bool (to_boolean (val));
- }
else if (var == ly_symbol2scm ("strict-infinity-checking"))
{
strict_infinity_checking = to_boolean (val);
SCM props = updated_grob_properties (context (), ly_symbol2scm ("System"));
- Object_key const *sys_key = context ()->get_grob_key ("System");
+ Object_key const *sys_key = 0;
pscore_->typeset_system (new System (props, sys_key));
system_ = pscore_->root_system ();
Axis_group_interface::add_element (this, p);
}
-void
-apply_tweaks (Grob *g, bool broken)
-{
- if (bool (g->original ()) == broken)
- {
- SCM tweaks = global_registry_->get_tweaks (g);
- for (SCM s = tweaks; scm_is_pair (s); s = scm_cdr (s))
- {
- SCM proc = scm_caar (s);
- SCM rest = scm_cdar (s);
- scm_apply_1 (proc, g->self_scm (), rest);
- }
- }
-}
-
void
System::pre_processing ()
{
fixup_refpoints (all_elements_->array ());
- for (vsize i = 0; i < all_elements_->size (); i++)
- apply_tweaks (all_elements_->grob (i), false);
-
for (vsize i = 0; i < all_elements_->size (); i++)
{
Grob *g = all_elements_->grob (i);
{
Grob *g = all_elements_->grob (i);
- apply_tweaks (g, true);
(void) g->get_property ("after-line-breaking");
}
if (ly_is_equal (right_ev->get_property ("pitch"),
left_ev->get_property ("pitch")))
{
- Grob *p = new Spanner (heads_to_tie_[i].tie_definition_,
- context ()->get_grob_key ("Tie"));
+ Grob *p = new Spanner (heads_to_tie_[i].tie_definition_, 0);
SCM cause = heads_to_tie_[i].tie_event_
? heads_to_tie_[i].tie_event_->self_scm ()
+++ /dev/null
-/*
- tweak-engraver.cc -- implement Tweak_engraver
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2005--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-
-*/
-
-#include "engraver.hh"
-
-#include "grob.hh"
-#include "stream-event.hh"
-#include "translator.icc"
-
-class Tweak_engraver : public Engraver
-{
- TRANSLATOR_DECLARATIONS (Tweak_engraver);
-
-protected:
- DECLARE_ACKNOWLEDGER (grob);
-};
-
-Tweak_engraver::Tweak_engraver()
-{
-}
-
-void
-Tweak_engraver::acknowledge_grob (Grob_info info)
-{
- if (Stream_event *ev = info.event_cause ())
- {
- for (SCM s = ev->get_property ("tweaks");
- scm_is_pair (s); s = scm_cdr (s))
- {
- info.grob ()->set_property (scm_caar (s), scm_cdar (s));
- }
- }
-}
-
-ADD_ACKNOWLEDGER (Tweak_engraver, grob);
-ADD_TRANSLATOR (Tweak_engraver,
- /* doc */ "Read the @code{tweaks} property from the originating event, and set properties." ,
-
- /* create */ "",
- /* read */ "",
- /* write */ "");
+++ /dev/null
-/*
- tweak-registration-scheme.cc -- implement Tweak_registry bindings
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#include "tweak-registration.hh"
-#include "grob.hh"
-#include "object-key-undumper.hh"
-
-LY_DEFINE (ly_clear_tweak_registry, "ly:tweak-clear-registry",
- 0, 0, 0, (),
- "Clear global tweak registry")
-{
- global_registry_->clear ();
- return SCM_UNSPECIFIED;
-}
-
-LY_DEFINE (ly_grob_insert_tweak, "ly:grob-insert-tweak",
- 2, 0, 0,
- (SCM grob, SCM tweak),
- "add new tweak for grob.")
-{
- Grob *gr = unsmob_grob (grob);
- SCM_ASSERT_TYPE (gr, grob, SCM_ARG1, __FUNCTION__, "Grob");
- SCM_ASSERT_TYPE (scm_list_p (tweak) == SCM_BOOL_T
- && ly_is_procedure (scm_car (tweak)),
- tweak, SCM_ARG2, __FUNCTION__, "Tweak");
-
- global_registry_->insert_grob_tweak (gr, tweak);
- return SCM_UNSPECIFIED;
-}
-
-LY_DEFINE (ly_grob_replace_tweak, "ly:grob-replace-tweak",
- 2, 0, 0,
- (SCM grob, SCM tweak),
- "Replace tweak for grob.")
-{
- Grob *gr = unsmob_grob (grob);
- SCM_ASSERT_TYPE (gr, grob, SCM_ARG1, __FUNCTION__, "Grob");
- SCM_ASSERT_TYPE (scm_list_p (tweak) == SCM_BOOL_T
- && ly_is_procedure (scm_car (tweak)),
- tweak, SCM_ARG2, __FUNCTION__, "Tweak");
-
- global_registry_->replace_grob_tweak (gr, tweak);
- return SCM_UNSPECIFIED;
-}
-
-LY_DEFINE (ly_tweak_read_keys, "ly:tweak-define-keys",
- 1, 0, 0, (SCM keys),
- "Read keys")
-{
- global_registry_->undumper ()->parse_contents (keys);
- return SCM_UNSPECIFIED;
-}
-
-LY_DEFINE (ly_all_tweaks, "ly:all-tweaks",
- 0, 0, 0, (),
- "all tweaks")
-{
- return global_registry_->list_tweaks ();
-}
-
-LY_DEFINE (ly_tweak_read_tweaks, "ly:tweak-define-tweaks",
- 1, 0, 0, (SCM tweaks),
- "Read tweaks")
-{
- for (SCM s = tweaks; scm_is_pair (s); s = scm_cdr (s))
- global_registry_->insert_tweak_from_file (scm_car (s));
- return SCM_UNSPECIFIED;
-}
+++ /dev/null
-/*
- tweak-registration.cc -- implement Tweak_registry
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-*/
-
-#include "tweak-registration.hh"
-
-#include "object-key-undumper.hh"
-#include "grob.hh"
-
-#include "ly-smobs.icc"
-
-Tweak_registry::Tweak_registry ()
-{
- undumper_ = 0;
- smobify_self ();
- undumper_ = new Object_key_undumper ();
- undumper_->unprotect ();
-}
-
-Tweak_registry::~Tweak_registry ()
-{
-}
-
-void
-Tweak_registry::clear ()
-{
- tweaks_.clear ();
- undumper_ = new Object_key_undumper ();
- undumper_->unprotect ();
-}
-
-void
-Tweak_registry::insert_tweak_from_file (SCM tweak)
-{
- SCM skey = scm_car (tweak);
-
- assert (scm_is_pair (skey)
- && scm_car (skey) == ly_symbol2scm ("key"));
-
- Object_key const *key = undumper_->get_key (scm_to_int (scm_cadr (skey)));
-
- SCM existing = SCM_EOL;
- Tweak_map::const_iterator prev = tweaks_.find (key);
- if (prev != tweaks_.end ())
- existing = (*prev).second;
-
- tweaks_[key] = scm_cons (scm_cdr (tweak), existing);
-}
-
-void
-Tweak_registry::insert_grob_tweak (Grob *g, SCM tweak)
-{
- Object_key const *key = g->key ();
- if (tweaks_.find (key) == tweaks_.end ())
- tweaks_[key] = SCM_EOL;
-
- tweaks_[key] = scm_cons (tweak, tweaks_[key]);
-}
-
-void
-Tweak_registry::replace_grob_tweak (Grob *g, SCM tweak)
-{
- Object_key const *key = g->key ();
- tweaks_[key] = scm_cons (tweak, SCM_EOL);
-}
-
-SCM
-Tweak_registry::get_tweaks (Grob *g)
-{
- Object_key const *key = g->key ();
- if (tweaks_.find (key) == tweaks_.end ())
- return SCM_EOL;
- return tweaks_[key];
-}
-
-SCM
-Tweak_registry::list_tweaks ()
-{
- SCM retval = SCM_EOL;
- for (Tweak_map::const_iterator i (tweaks_.begin ());
- i != tweaks_.end ();
- i++)
- {
- Object_key const *key = (*i).first;
- for (SCM t = (*i).second; scm_is_pair (t); t = scm_cdr (t))
- retval = scm_cons (scm_cons (key->self_scm (), scm_car (t)), retval);
- }
-
- return retval;
-}
-
-SCM
-Tweak_registry::mark_smob (SCM smob)
-{
- Tweak_registry *me = (Tweak_registry *) SCM_CELL_WORD_1 (smob);
-
- for (Tweak_map::const_iterator i (me->tweaks_.begin ());
- i != me->tweaks_.end ();
- i++)
- {
- scm_gc_mark ((*i).first->self_scm ());
- scm_gc_mark ((*i).second);
- }
-
- if (me->undumper_)
- scm_gc_mark (me->undumper_->self_scm ());
-
- return SCM_EOL;
-}
-
-int
-Tweak_registry::print_smob (SCM smob, SCM port, scm_print_state*)
-{
- (void) smob; // smother warning.
- scm_puts ("#<Tweak_registry>", port);
- return 1;
-}
-
-Object_key_undumper *
-Tweak_registry::undumper () const
-{
- return undumper_;
-}
-
-IMPLEMENT_DEFAULT_EQUAL_P (Tweak_registry);
-IMPLEMENT_SMOBS (Tweak_registry);
-
-Tweak_registry *global_registry_;
-
-void
-init_global_tweak_registry ()
-{
- global_registry_ = new Tweak_registry ();
-}
\consists "Vertical_align_engraver"
\consists "Stanza_number_align_engraver"
\consists "Bar_number_engraver"
- \consists "Tweak_engraver"
\consists "Parenthesis_engraver"
\defaultchild "Staff"
(quoted-context-id ,string? "The id of the context to direct quotes to, eg., @code{cue}.")
(quoted-transposition ,ly:pitch? "The pitch used for the quote, overriding \\transposition")
(to-relative-callback ,procedure? "How to transform a piece of music to relative pitches")
- (tweaks ,list? "An alist of properties to override in the backend
-for the grob made of this event.")
-
(repeat-count ,integer? "do a @code{\repeat} how ofen?")
(span-direction ,ly:dir? "Does this start or stop a spanner?")
(span-type ,string? "What kind of spanner should be created?
-;;;; framework-gnome.scm --
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2004--2006 Jan Nieuwenhuizen <janneke@gnu.org>
-
-;;;; See output-gnome.scm for usage information.
-
-
-(define-module (scm framework-gnome))
-
-(use-modules (guile)
- (oop goops)
- (scm page)
- (scm paper-system)
- (lily))
-
-(use-modules
- (srfi srfi-2)
- (ice-9 regex)
- (gnome gtk)
- (gnome gtk gdk-event)
- (gnome gw canvas))
-
-(define-public (output-framework basename book scopes fields )
- (gnome-main book basename))
-
-(define SCROLLBAR-SIZE 20)
-(define BUTTON-HEIGHT 25)
-(define PANELS-HEIGHT 80)
-
-(define PIXELS-PER-UNIT 2)
-;; 2.5??
-(define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT))
-(define-public output-scale OUTPUT-SCALE)
-
-(define (debugf string . rest)
- (if #f
- (apply stderr (cons string rest))))
-
-(define-class <gnome-outputter> ()
- (name #:init-value "untitled" #:init-keyword #:name #:accessor name)
-
- ;; FIXME
- (dragging #:init-value #f #:accessor dragging)
- (drag-origin #:init-value #f #:accessor drag-origin)
- (drag-location #:init-value #f #:accessor drag-location)
-
- (page-stencils ;;#:init-value '#()
- #:init-keyword #:page-stencils #:accessor page-stencils)
- (window #:init-value (make <gtk-window> #:type 'toplevel) #:accessor window)
- (scrolled #:init-value (make <gtk-scrolled-window>) #:accessor scrolled)
- (canvas #:init-value #f #:accessor canvas)
- (page-number #:init-value 0 #:accessor page-number)
- (pixels-per-unit #:init-value PIXELS-PER-UNIT #:accessor pixels-per-unit)
- (text-items #:init-value '() #:accessor text-items)
- (grob #:init-value #f #:accessor grob)
- (item-grobs #:init-value (make-hash-table 31) #:accessor item-grobs)
- (window-width #:init-keyword #:window-width #:accessor window-width)
- (window-height #:init-keyword #:window-height #:accessor window-height)
- (canvas-width #:init-keyword #:canvas-width #:accessor canvas-width)
- (canvas-height #:init-keyword #:canvas-height #:accessor canvas-height))
-
-(define-method (initialize (go <gnome-outputter>))
- (let* ((save (make <gtk-button> #:label "Save"))
- (exit (make <gtk-button> #:label "Exit"))
- (next (make <gtk-button> #:label "Next"))
- (prev (make <gtk-button> #:label "Previous"))
- (vbox (make <gtk-vbox> #:homogeneous #f))
- (hbox (make <gtk-hbox> #:homogeneous #f)))
-
- (set-size-request (window go) (window-width go) (window-height go))
-
- (set-size-request (scrolled go) (window-width go) (- (window-height go)
- BUTTON-HEIGHT
- SCROLLBAR-SIZE))
-
- (new-canvas go)
-
- (add (window go) vbox)
- (add vbox (scrolled go))
-
- (add (scrolled go) (canvas go))
-
- ;; buttons
- (add vbox hbox)
- (set-size-request hbox (window-width go) BUTTON-HEIGHT)
-
- ;; hmm? These are broken when using <gnome-outputter>.
- ;;(set-child-packing vbox hbox #f #f 0 'end)
- ;;(set-child-packing hbox button #f #f 0 'end)
-
- (set-size-request exit (quotient (window-width go) 2) BUTTON-HEIGHT)
-
-
- (add hbox next)
- (add hbox prev)
- (add hbox save)
- (add hbox exit)
-
- ;; signals
- (connect exit 'clicked (lambda (b) (gtk-main-quit)))
- (connect save 'clicked (lambda (b) (save-tweaks go)))
- (connect next 'clicked (lambda (b) (dump-page go (1+ (page-number go)))))
- (connect prev 'clicked (lambda (b) (dump-page go (1- (page-number go)))))
- (connect (window go) 'key-press-event
- (lambda (w e) (key-press-event go w e)))
-
- (show-all (window go))))
-
-
-(define (gnome-main book name)
- (let* ((paper (ly:paper-book-paper book))
- (paper-width (ly:output-def-lookup paper 'paper-width))
- (paper-height (ly:output-def-lookup paper 'paper-height))
- (page-width (inexact->exact (ceiling (* OUTPUT-SCALE paper-width))))
- (page-height (inexact->exact (ceiling (* OUTPUT-SCALE paper-height))))
- ;;(page-width (inexact->exact (ceiling paper-width)))
- ;;(page-height (inexact->exact (ceiling paper-height)))
-
- (screen-width (gdk-screen-width))
- (screen-height (gdk-screen-height))
- (desktop-height (- screen-height PANELS-HEIGHT))
-
- (go (make <gnome-outputter>
- #:name name
- #:page-stencils (list->vector (map page-stencil (ly:paper-book-pages book)))
- #:canvas-width page-width
- #:canvas-height page-height
- #:window-width
- ;; huh, *2 -- pixels-per-unit?
- (min (+ SCROLLBAR-SIZE (* page-width 2)) screen-width)
- #:window-height
- (min (+ BUTTON-HEIGHT SCROLLBAR-SIZE (* page-height 2))
- desktop-height))))
-
- ;; ugh. The GOOPS doc promises this is called automagically.
- ;; possibly a goops 1.6.4 problem
- (initialize go)
-
- (dump-page go 0)
-
- (gtk-main)))
-
-(define (dump-page go number)
- (if (or (not (page-stencils go))
- (< number 0)
- (>= number (vector-length (page-stencils go))))
- (stderr "No such page: ~S\n" (1+ number))
-
- (let ((old-canvas (canvas go)))
- (new-canvas go)
- (set! (page-number go) number)
-
- ;; no destroy method for gnome-canvas-text yet.
- ;;(map destroy (gtk-container-get-children main-canvas))
- ;;(map destroy text-items)
-
- (set! (text-items go) '())
- (debugf "page-stencil ~S: ~S\n"
- (page-number go)
- (vector-ref (page-stencils go) (page-number go)))
-
- (ly:interpret-stencil-expression
- ;; ;;(vector-ref (page-stencils go) (page-number go))
- (ly:stencil-expr (vector-ref (page-stencils go) (page-number go)))
- gnome-output-expression go '(0 . 0))
-
- (if old-canvas (destroy old-canvas))
- (add (scrolled go) (canvas go))
- (show (canvas go)))))
-
-(define ifs #f)
-(define (get-ifs)
- (if (not ifs)
- (set! ifs (getenv "IFS")))
- (if (not ifs)
- (set! ifs " "))
- ifs)
-
-(define (spawn-editor location)
- (let* ((file-name (car location))
- (line (cadr location))
- (char (caddr location))
- (column (cadddr location))
- (command (get-editor-command file line char column)))
- (debugf "spawning: ~s\n" command)
- (if (= (primitive-fork) 0)
- (let ((command-list (string-split command #\ )));; (get-ifs))))
- (apply execlp command-list)
- (primitive-exit)))))
-
-(define location-callback spawn-editor)
-
-(define (get-location grob)
- (and-let* ((p (procedure? point-and-click))
- (g grob)
- (cause (ly:grob-property grob 'cause))
- (music-origin (if (ly:event? cause)
- (ly:event-property cause 'origin)
- ;; How come #<unspecified> [and '()]
- ;; are #t? :-(
- #f)))
- (if (ly:input-location? music-origin)
- (ly:input-location music-origin)
- #f)))
-
-;; todo: how to integrate nicely?
-;(define-public (tweak-grob-property grob sym val)
-; (set! (ly:grob-property grob sym) val))
-
-
-(define-method (tweak (go <gnome-outputter>) item offset)
- (let* ((grob (hashq-ref (item-grobs go) item #f))
- (extra-offset (ly:grob-property grob 'extra-offset))
- (origin (if (null? extra-offset) '(0 . 0)
- (offset-flip-y extra-offset))))
-
- (if grob
- (ly:grob-replace-tweak
- grob (list tweak-grob-property
- 'extra-offset
- (offset-flip-y (offset-add origin offset)))))))
-
-(define-method (save-tweaks (go <gnome-outputter>))
- (let* ((dumper (ly:make-dumper))
- (tweaks (ly:all-tweaks))
- (serialized-tweaks
- (map
- (lambda (tweak) (append
- (list (ly:dumper-key-serial dumper (car tweak))
- (list 'unquote (procedure-name (cadr tweak))))
- (cddr tweak)))
- tweaks)))
-
- (if (not (null? serialized-tweaks))
- (let ((file (open-file (string-append (name go) ".twy") "w")))
- (format file
- ";;;tweaks. Generated file. Do not edit.
-(ly:tweak-clear-registry)
-(ly:tweak-define-keys `~S)
-(ly:tweak-define-tweaks `~S)"
- (ly:dumper-definitions dumper)
- serialized-tweaks)))))
-
-;;;(define (item-event go grob item event)
-(define (item-event go item event)
- ;;(stderr "EVENT: ~S\n" event)
- ;;(stderr "TYPE: ~S\n" (gdk-event:type event))
- (case (gdk-event:type event)
- ((enter-notify) (gobject-set-property item 'fill-color "red"))
- ((leave-notify) (gobject-set-property item 'fill-color "black"))
- ((motion-notify) (if (ly:grob? (dragging go))
- (let ((x (gdk-event-motion:x event))
- (y (gdk-event-motion:y event))
- (s output-scale)
- (r (drag-location go)))
- ;;(stderr "MOVED AT: ~S ~S\n" x y)
- (move item (/ (- x (car r)) s) (/ (- y (cdr r)) s))
- (set! (drag-location go) (cons x y)))))
- ((button-release) (if (ly:grob? (dragging go))
- (let ((x (gdk-event-button:x event))
- (y (gdk-event-button:y event))
- (s output-scale)
- (o (drag-origin go))
- (r (drag-location go)))
- (move item (/ (- x (car r)) s) (/ (- y (cdr r)) s))
- (set! (drag-location go) #f)
- (set! (drag-origin go) #f)
- (stderr "RELEASE at: ~S ~S\n" x y)
- (set! (dragging go) #f)
- (tweak go item (cons (/ (- x (car o)) s)
- (/ (- y (cdr o)) s))))))
- ((button-press)
- (let ((button (gdk-event-button:button event)))
- (cond
- ((= button 1)
- (if (null? (gdk-event-button:modifiers event))
- (let ((x (gdk-event-button:x event))
- (y (gdk-event-button:y event)))
- (stderr "CLICK at: ~S ~S\n" x y)
- (set! (dragging go) (hashq-ref (item-grobs go) item #f))
- (set! (drag-origin go) (cons x y))
- (set! (drag-location go) (cons x y)))
- (begin
- (stderr "CLICK WITH MODIFIERS: ~S\n"
- (gdk-event-button:modifiers event))
-
- ;; some modifier, do jump to source
- (and-let* ((grob (hashq-ref (item-grobs go) item #f))
- (location (get-location grob)))
- (location-callback location)))))
- ((= button 2)
- (and-let* ((grob (hashq-ref (item-grobs go) item #f)))
-
- (let ((properties (ly:grob-properties grob))
- (basic-properties (ly:grob-basic-properties grob))
- (x (inexact->exact (gdk-event-button:x-root event)))
- (y (inexact->exact (gdk-event-button:y-root event))))
-
- (debugf "GROB: ~S\n" grob)
- (debugf "PROPERTIES: ~S\n" properties)
- (debugf "BASIC PROPERTIES: ~S\n" basic-properties)
-
- ;; FIXME: dialog iso window?
- ;; http://www.gtk.org/tutorial/sec-textentries.html
- (let ((window (make <gtk-window>))
- (vbox (make <gtk-vbox>))
- (ok (make <gtk-button> #:label "Ok")))
-
- (add window vbox)
- (connect ok 'clicked (lambda (b) (destroy window)))
-
- (for-each
- (lambda (x)
- (let ((label (make <gtk-label>
- ;;#:label (symbol->string (car x))))
- #:label (format #f "~S" (car x))))
- ;;(symbol->string (car x))))
- (entry (make <gtk-entry>
- #:text (format #f "~S" (cdr x))))
- (hbox (make <gtk-hbox>)))
- (add hbox label)
- (add hbox entry)
- (set-size-request label 150 BUTTON-HEIGHT)
- (add vbox hbox)))
- (append properties basic-properties))
- (add vbox ok)
-
- (show-all window)
- (move window x y))))))))
-
- ((2button-press) (gobject-set-property item 'fill-color "green"))
- ((key-press)
- (let ((keyval (gdk-event-key:keyval event))
- (mods (gdk-event-key:modifiers event))
- (step (quotient (pixels-per-unit go) 2)))
- (cond ((and (null? mods)
- (eq? keyval gdk:Up))
- (tweak go item (cons 0 (- 0 step))))
- ((and (null? mods)
- (eq? keyval gdk:Down))
- (tweak go item (cons 0 step)))
- ((and (null? mods)
- (eq? keyval gdk:Left))
- (tweak go item (cons (- 0 step) 0)))
- ((and (null? mods)
- (eq? keyval gdk:Right))
- (tweak go item (cons step 0)))))))
- #t)
-
-(define (scale-canvas go factor)
- (set! (pixels-per-unit go) (* (pixels-per-unit go) factor))
- (set-pixels-per-unit (canvas go) (pixels-per-unit go))
- (for-each
- (lambda (x)
- (let ((scale (gobject-get-property x 'scale))
- (points (gobject-get-property x 'size-points)))
- ;;(gobject-set-property x 'scale pixels-per-unit)
- (gobject-set-property x 'size-points (* points factor))))
- (text-items go)))
-
-(define (key-press-event go item event)
- (let ((keyval (gdk-event-key:keyval event))
- (mods (gdk-event-key:modifiers event)))
- (cond ((and (or (eq? keyval gdk:q)
- (eq? keyval gdk:w))
- (equal? mods '(control-mask modifier-mask)))
- (gtk-main-quit))
- ((and (eq? keyval gdk:s)
- (equal? mods '(control-mask modifier-mask)))
- (save-tweaks go))
- ((and #t ;;(null? mods)
- (eq? keyval gdk:plus))
- (scale-canvas go 2))
- ((and #t ;; (null? mods)
- (eq? keyval gdk:minus))
- (scale-canvas go 0.5))
- ((or (eq? keyval gdk:Page-Up)
- (eq? keyval gdk:BackSpace))
- (dump-page go (1- (page-number go))))
- ((or (eq? keyval gdk:Page-Down)
- (eq? keyval gdk:space))
- (dump-page go (1+ (page-number go)))))
- #f))
-
-(define (new-canvas go)
- (set! (canvas go) (make <gnome-canvas>))
- (set-size-request (canvas go) (window-width go) (window-height go))
- (set-scroll-region (canvas go) 0 0 (canvas-width go) (canvas-height go))
- (set-pixels-per-unit (canvas go) (pixels-per-unit go))
- (make <gnome-canvas-rect>
- #:parent (root (canvas go))
- #:x2 (canvas-width go) #:y2 (canvas-height go)
- #:fill-color "white"))
-
-(define output-gnome-module #f)
-(define (get-output-gnome-module go)
- (if (not output-gnome-module)
- (let ((m (resolve-module '(scm output-gnome))))
- (module-define! m 'canvas-root (lambda () (root (canvas go))))
- (module-define! m 'output-scale output-scale)
- (set! output-gnome-module m)))
- output-gnome-module)
-
-(define-public (gnome-output-expression go expr)
- (let* ((m (get-output-gnome-module go))
- (result (eval expr m)))
- (cond
- ((ly:grob? result) (set! (grob go) result))
- ((is-a? result <gnome-canvas-item>)
-
- ;; AAARGH; grobs happen after stencils
- ;; (connect result 'event (lambda (w e) (item-event go (grob go) w e)))
- (connect result 'event (lambda (w e) (item-event go w e)))
- (if (grob go)
- (hashq-set! (item-grobs go) result (grob go)))
- (set! (grob go) #f)
-
- (if (is-a? result <gnome-canvas-text>)
- (set! (text-items go) (cons result (text-items go))))))))
(delete-intermediate-files #f
"delete unusable PostScript files")
(dump-profile #f "dump timing information for each file")
- (dump-tweaks #f "dump page layout and tweaks for each score having the tweak-key layout property set.")
(dump-signatures #f "dump output signatures of each system. Used for regression testing.")
(eps-box-padding #f "Pad EPS bounding box left edge. Guarantee alignment between systems in LaTeX.")
(old-relative #f
"relative for simultaneous music works
similar to chord syntax")
- (object-keys #f
- "experimental mechanism for remembering tweaks")
(point-and-click #t "use point & click")
(paper-size "a4" "the default paper size")
(pixmap-format "png16m" "GS format to use for pixel images")
-;;;; output-gnome.scm -- implement GNOME canvas output
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2004--2006 Jan Nieuwenhuizen <janneke@gnu.org>
-
-;;;; TODO:
-;;;;
-;;;; * .cff MUST NOT be in fc's fontpath.
-;;;; - workaround: remove mf/out from ~/.fonts.conf,
-;;;; instead add ~/.fonts and symlink all /mf/out/*otf there.
-;;;; - bug in fontconfig/freetype/pango?
-
-;;; * check: blot+scaling
-;;; * Figure out and fix font scaling and character placement
-;;; * EC font package: add missing X font directories and AFMs
-;;; * User-interface, keybindings
-;;; * Implement missing stencil functions
-;;; * Implement missing commands
-;;; * More information in stencils, e.g., location and grob tag.
-;;; * Embedded Lily:
-;;; - allow GnomeCanvas or `toplevel' GtkWindow to be created
-;;; outside of LilyPond
-;;; - lilylib.
-;;; * Release schedule and packaging of dependencies.
-;;; - g-wrap-1.9.3 is already in incoming.
-;;; - guile-gnome-platform-2.8.0 will probably be packaged early 2005.
-
-;;; You need:
-;;;
-;;; * Rotty's g-wrap >= 1.9.3
-;;; * guile-gnome-platform >= 2.7.97
-;;; * pango >= 1.6.0
-;;;
-;;; See also: guile-gtk-general@gnu.org
-
-;;; Try it
-;;;
-;;; * Install gnome/gtk and libffi development stuff
-;;;
-;;; * Install [pango, g-wrap and] guile-gnome from source,
-;;; see buildscripts/guile-gnome.sh
-;;;
-;;; * Build LilyPond with gui support: configure --enable-gui
-;;;
-;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond,
-;;; tell fontconfig about the feta fonts dir and run fc-cache
-"
-cat > ~/.fonts.conf << EOF
-<fontconfig>
-<dir>~/cvs/savannah/lilypond/mf/out</dir>
-<dir>/usr/share/texmf/fonts/type1/public/ec-fonts-mftraced</dir>
-</fontconfig>
-EOF
-fc-cache
-"
-;;; or copy all your .pfa/.pfb's to ~/.fonts if your fontconfig
-;;; already looks there for fonts. Check if it works by doing:
-"
-fc-list | grep -i lily
-"
-;;;
-;;; * Setup environment
-"
-export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
-export LD_LIBRARY_PATH=$HOME/usr/pkg/pango/lib:$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
-export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f'
-"
-;;; * Also for GNOME point-and-click, you need to set XEDITOR and add
-"
-#(ly:set-point-and-click 'line-column)
-"
-;;; to your .ly.
-;;;
-;;; * Run lily:
-"
-lilypond -fgnome input/simple-song.ly
-"
-;;; point-and-click: (mouse-1) click on a graphical object;
-;;; grob-property-list: (mouse-3) click on a graphical object.
-
-(define-module (scm output-gnome))
-(define this-module (current-module))
-
-(use-modules
- (guile)
- (ice-9 regex)
- (srfi srfi-13)
- (lily)
- (gnome gtk)
- (gnome gw canvas))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; globals
-
-;;; set by framework-gnome.scm
-(define canvas-root #f)
-(define output-scale #f)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; helper functions
-
-(define (utf-8 i)
- (cond
- ((< i #x80) (list (integer->char i)))
- ((< i #x800) (map integer->char
- (list (+ #xc0 (quotient i #x40))
- (+ #x80 (modulo i #x40)))))
- ((< i #x10000)
- (let ((x (quotient i #x1000))
- (y (modulo i #x1000)))
- (map integer->char
- (list (+ #xe0 x)
- (+ #x80 (quotient y #x40))
- (+ #x80 (modulo y #x40))))))
- (else (begin (stderr "programming-error: utf-8 too big:~x\n" i)
- (list (integer->char 32))))))
-
-(define (integer->utf-8-string integer)
- (list->string (utf-8 integer)))
-
-(define (char->utf-8-string char)
- (list->string (utf-8 (char->integer char))))
-
-(define (string->utf-8-string string)
- (apply
- string-append
- (map (lambda (x) (char->utf-8-string x)) (string->list string))))
-
-(define (music-font? font)
- (let ((family (car (font-name-style font))))
- (string=? (substring family 0 (min (string-length family) 10))
- "Emmentaler")))
-
-;;; FONT may be font smob, or pango font string
-(define (pango-font-name font)
- (if (string? font)
- (list font "Regular")
- (apply format (append '(#f "~a, ~a") (font-name-style font)))))
-
-;;; FONT may be font smob, or pango font string
-(define (canvas-font-size font)
- ;; FIXME: 1.85?
- (* 1.85
- (if (string? font)
- 12
- (* output-scale (modified-font-metric-font-scaling font)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Wrappers from guile-gnome TLA
-;;; guile-gnome-devel@gnu.org--2004
-;;; http://arch.gna.org/guile-gnome/archive-2004
-;;;
-;;; janneke@gnu.org--2004-gnome
-;;; http://lilypond.org/~janneke/{arch}/2004-gnome
-;;;
-(if (not (defined? '<gnome-canvas-path-def>))
- (begin
- (define-class <gnome-canvas-path-def> (<gobject>)
- (closure #:init-value (gnome-canvas-path-def-new)
- #:init-keyword #:path-def
- #:getter get-def #:setter set-def))
-
- (define-method (moveto (this <gnome-canvas-path-def>) x y)
- (gnome-canvas-path-def-moveto (get-def this) x y))
- (define-method (curveto (this <gnome-canvas-path-def>) x1 y1 x2 y2 x3 y3)
- (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3))
- (define-method (lineto (this <gnome-canvas-path-def>) x y)
- (gnome-canvas-path-def-lineto (get-def this) x y))
- (define-method (closepath (this <gnome-canvas-path-def>))
- (gnome-canvas-path-def-closepath (get-def this)))
- (define-method (reset (this <gnome-canvas-path-def>))
- (gnome-canvas-path-def-reset (get-def this)))
-
- (define -set-path-def set-path-def)
- (define -get-path-def get-path-def)
-
- (define-method (set-path-def (this <gnome-canvas-shape>)
- (def <gnome-canvas-path-def>))
- (-set-path-def this (get-def def)))
-
- (define-method (get-path-def (this <gnome-canvas-shape>))
- (make <gnome-canvas-path-def> #:path-def (-get-path-def this)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; stencil outputters
-;;;
-
-;;; catch-all for missing stuff
-;;; comment this out to see find out what functions you miss :-)
-(define (dummy . foo) #f)
-(map (lambda (x) (module-define! this-module x dummy))
- (append
- (ly:all-stencil-expressions)
- (ly:all-output-backend-commands)))
-
-;; two beziers
-(define (bezier-sandwich lst thick)
- (let* ((def (make <gnome-canvas-path-def>))
- (bezier (make <gnome-canvas-bpath>
- #:parent (canvas-root)
- #:fill-color "black"
- #:outline-color "black"
- #:width-units thick
- #:join-style 'round)))
-
- (reset def)
-
- ;; FIXME: LST is pre-mangled for direct ps stack usage
- ;; cl cr r l 0 1 2 3
- ;; cr cl l r 4 5 6 7
-
- (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
- (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0)))
- (car (list-ref lst 1)) (- (cdr (list-ref lst 1)))
- (car (list-ref lst 2)) (- (cdr (list-ref lst 2))))
-
- (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7))))
- (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4)))
- (car (list-ref lst 5)) (- (cdr (list-ref lst 5)))
- (car (list-ref lst 6)) (- (cdr (list-ref lst 6))))
- (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
-
- (closepath def)
- (set-path-def bezier def)
- bezier))
-
-(define (char font i)
- (text font (ly:font-index-to-charcode font i)))
-
-(define (dashed-line thick on off dx dy)
- (draw-line thick 0 0 dx dy))
-
-(define (draw-line thick x1 y1 x2 y2)
- (let* ((def (make <gnome-canvas-path-def>))
- (props (make <gnome-canvas-bpath>
- #:parent (canvas-root)
- #:fill-color "black"
- #:outline-color "black"
- #:width-units thick)))
- (reset def)
- (moveto def x1 (- y1))
- (lineto def x2 (- y2))
- (set-path-def props def)
- props))
-
-
-;; FIXME: the framework-gnome backend needs to see every item that
-;; gets created. All items created here must should be put in a group
-;; that gets returned.
-(define (glyph-string font postscript-font-name w-x-y-named-glyphs)
- (for-each
- (lambda (x)
-
- ;; UGR, glyph names not found
- (stderr "GLYPH:~S\n" (caddr x))
- (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x)))
- (placebox (cadr x) (caddr x)
- (make <gnome-canvas-text>
- #:parent (canvas-root)
- ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69)
- #:x 0.0 #:y 0.0
- #:anchor 'west
- #:font (pango-font-name font)
- #:size-points (canvas-font-size font)
- #:size-set #t
- #:text
- (integer->utf-8-string
- (ly:font-glyph-name-to-charcode font (cadddr x))))))
- w-x-y-named-glyphs))
-
-(define (grob-cause offset grob)
- grob)
-
-
-(define (named-glyph font name)
- (text font (ly:font-glyph-name-to-charcode font name)))
-
-(define (placebox x y expr)
- (let ((item expr))
- ;;(if item
- ;; FIXME ugly hack to skip #unspecified ...
- (if (and item (not (eq? item (if #f #f))))
- (begin
- (move item (* output-scale x) (* output-scale (- y)))
- (affine-relative item output-scale 0 0 output-scale 0 0)
- item)
- #f)))
-
-(define (polygon coords blot-diameter)
- (let* ((def (make <gnome-canvas-path-def>))
- (props (make <gnome-canvas-bpath>
- #:parent (canvas-root)
- #:fill-color "black"
- #:outline-color "black"
- #:join-style 'round)
- #:width-units blot-diameter)
- (points (ly:list->offsets '() coords))
- (last-point (car (last-pair points))))
-
- (reset def)
- (moveto def (car last-point) (cdr last-point))
- (for-each (lambda (x) (lineto def (car x) (cdr x))) points)
- (closepath def)
- (set-path-def props def)
- props))
-
-(define (round-filled-box breapth width depth height blot-diameter)
- (let ((r (/ blot-diameter 2)))
- (make <gnome-canvas-rect>
- #:parent (canvas-root)
- #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height)
- #:fill-color "black"
- #:outline-color "black"
- #:width-units blot-diameter
- #:join-style 'round)))
-
-(define (text font s)
- (make <gnome-canvas-text>
- #:parent (canvas-root)
- ;;#:x 0.0 #:y 0.0
- #:x 0.0 #:y (if (music-font? font) 0.15 0.69)
- #:anchor (if (music-font? font) 'west 'south-west)
- #:font (pango-font-name font)
- #:size-points (canvas-font-size font)
- #:size-set #t
- #:text (if (integer? s)
- (integer->utf-8-string s)
- (string->utf-8-string s))))
-
-(define (utf-8-string pango-font-description string)
- (make <gnome-canvas-text>
- #:parent (canvas-root)
- #:x 0.0 #:y 0.0
- #:anchor 'west
- #:font pango-font-description
- #:size-points (canvas-font-size pango-font-description)
- #:size-set #t
- #:text string))
projects / lilypond.git / commitdiff