* scm/lily.scm (ly:all-output-backend-commands): New function.
* scm/safe-lily.scm (safe-objects): Add them.
* scm/framework-gnome.scm (<gnome-outputter>): New class.
* scm/output-gnome.scm: Move non-stencil evaluators to framework.
2004-06-16 Jan Nieuwenhuizen <janneke@gnu.org>
+ * lily/: Stray janitorial cleanups.
+
+ * scm/lily.scm (ly:all-stencil-expressions):
+ * scm/lily.scm (ly:all-output-backend-commands): New function.
+
+ * scm/safe-lily.scm (safe-objects): Add them.
+
* scm/framework-gnome.scm (<gnome-outputter>): New class.
* scm/output-gnome.scm: Move non-stencil evaluators to framework.
-% remove-me
-#(ly:set-point-and-click 'line-column)
-
%% A simple song in LilyPond
<<
\relative {
%% Optional helper for automatic updating by convert-ly. May be omitted.
\version "2.3.4"
+
+%% Optional helper for quick click and edit mode. May be omitted
+#(ly:set-point-and-click 'line-column)
+
+#(ly:set-point-and-click 'line-column)
\version "2.3.4"
\header {
#(set-default-paper-size "a6")
+
pattern = { a b c d \break }
\book {
\score {
/*
accidental-engraver.cc -- implement accidental_engraver
+ source file of the GNU LilyPond music typesetter
+
(c) 1997--2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
Modified 2001--2002 by Rune Zedeler <rz@daimi.au.dk>
*/
+#include "accidental-placement.hh"
+#include "arpeggio.hh"
+#include "context.hh"
+#include "engraver-group-engraver.hh"
+#include "engraver.hh"
#include "event.hh"
-#include "spanner.hh"
#include "item.hh"
-#include "tie.hh"
+#include "protected-scm.hh"
#include "rhythmic-head.hh"
-#include "engraver-group-engraver.hh"
-#include "accidental-placement.hh"
#include "side-position-interface.hh"
-#include "engraver.hh"
-#include "arpeggio.hh"
+#include "spanner.hh"
+#include "tie.hh"
#include "warn.hh"
-#include "context.hh"
-#include "protected-scm.hh"
-struct Accidental_entry {
+class Accidental_entry
+{
+public:
bool done_;
- Music * melodic_;
- Grob * accidental_;
+ Music *melodic_;
+ Grob *accidental_;
Context *origin_;
- Grob* head_;
+ Grob *head_;
bool tied_;
+
Accidental_entry ();
};
{
tied_ = false;
done_ = false;
- melodic_ =0;
+ melodic_ = 0;
accidental_ = 0;
origin_ = 0;
head_ = 0;
}
-struct Accidental_engraver : Engraver {
-
-
+class Accidental_engraver : public Engraver
+{
+public:
int get_bar_number ();
void update_local_key_signature ();
virtual void initialize ();
virtual void process_acknowledged_grobs ();
virtual void finalize ();
-public:
+public:
Protected_scm last_keysig_; // ugh.
- /*
- Urgh. Since the accidentals depend on lots of variables, we have to
- store all information before we can really create the accidentals.
- */
+ /* Urgh. Since the accidentals depend on lots of variables, we have
+ to store all information before we can really create the
+ accidentals. */
Link_array<Grob> left_objects_;
Link_array<Grob> right_objects_;
- Grob * accidental_placement_;
+ Grob *accidental_placement_;
Array<Accidental_entry> accidentals_;
Link_array<Spanner> ties_;
*/
static void
-set_property_on_children (Context * trans, const char * sym, SCM val)
+set_property_on_children (Context *trans, char const *sym, SCM val)
{
trans->set_property (sym, ly_deep_copy (val));
for (SCM p = trans->children_contexts (); ly_c_pair_p (p); p = ly_cdr (p))
{
- Context *trg = unsmob_context (ly_car (p));
+ Context *trg = unsmob_context (ly_car (p));
set_property_on_children (trg, sym, ly_deep_copy (val));
}
}
last_keysig_ = SCM_EOL;
}
-
void
Accidental_engraver::update_local_key_signature ()
{
last_keysig_ = get_property ("keySignature");
set_property_on_children (context (), "localKeySignature", last_keysig_);
- Context * trans = context ()->get_parent_context ();
+ Context *trans = context ()->get_parent_context ();
- /*
- Huh. Don't understand what this is good for. --hwn.
- */
+ /* Huh. Don't understand what this is good for. --hwn. */
while (trans && trans->where_defined (ly_symbol2scm ("localKeySignature")))
{
- trans->set_property ("localKeySignature",
- ly_deep_copy (last_keysig_));
+ trans->set_property ("localKeySignature", ly_deep_copy (last_keysig_));
trans = trans->get_parent_context ();
}
}
update_local_key_signature ();
}
-/*
-
- Calculates the number of accidentals on basis of the current local key
- sig (passed as argument)
-
- * First check step+octave (taking into account barnumbers if necessary).
- * Then check the global signature (only step).
-
-
-
- Returns number of accidentals (0, 1 or 2).
+/** Calculate the number of accidentals on basis of the current local key
+ sig (passed as argument)
+
+ * First check step+octave (taking into account barnumbers if necessary).
+
+ * Then check the global signature (only step).
-
-*/
+ Return number of accidentals (0, 1 or 2). */
static int
-number_accidentals_from_sig (bool *different,
- SCM sig, Pitch *pitch, int curbarnum, SCM laziness,
- bool ignore_octave)
+number_accidentals_from_sig (bool *different, SCM sig, Pitch *pitch,
+ int curbarnum, SCM laziness, bool ignore_octave)
{
int n = pitch->get_notename ();
int o = pitch->get_octave ();
if (ly_c_pair_p (prev_local))
{
if (ly_c_pair_p (ly_cdr (prev_local))
- && ly_c_number_p (laziness)
- )
+ && ly_c_number_p (laziness))
{
int barnum = ly_scm2int (ly_cddr (prev_local));
if (prev_alt == SCM_BOOL_F)
prev_alt = scm_assoc (scm_int2num (n), sig);
-
prev_alt = (prev_alt == SCM_BOOL_F) ? scm_int2num (0) : ly_cdr (prev_alt);
- /*
- UGH. prev_acc can be #t in case of ties. What is this for?
-
- */
+ /* UGH. prev_acc can be #t in case of ties. What is this for? */
int p = ly_c_number_p (prev_alt) ? ly_scm2int (prev_alt) : 0;
int num;
static int
number_accidentals (bool *different,
- Pitch *pitch, Context * origin,
+ Pitch *pitch, Context *origin,
SCM accidentals, int curbarnum)
{
int number = 0;
warning (_f ("Accidental typesetting list must begin with context-name: %s",
ly_scm2string (ly_car (accidentals)).to_str0 ()));
- for (; ly_c_pair_p (accidentals) && origin; accidentals = ly_cdr (accidentals))
+ for (; ly_c_pair_p (accidentals) && origin;
+ accidentals = ly_cdr (accidentals))
{
// If pair then it is a new accidentals typesetting rule to be checked
SCM rule = ly_car (accidentals);
*/
else if (ly_c_symbol_p (rule))
{
- Context * dad = origin;
+ Context *dad = origin;
while (dad && !dad->is_alias (rule))
dad = dad->get_parent_context ();
Moment mp = (unsmob_moment (smp)) ? *unsmob_moment (smp) : Moment (0);
if (mp.main_part_ < Rational (0))
- bn --;
+ bn--;
return bn;
}
int barnum = get_bar_number ();
bool extra_natural_b = get_property ("extraNatural") == SCM_BOOL_T;
- for (int i = 0; i < accidentals_.size (); i++)
+ for (int i = 0; i < accidentals_.size (); i++)
{
if (accidentals_[i].done_ )
continue;
accidentals_[i].done_ = true;
- Grob * support = accidentals_[i].head_;
- Music * note = accidentals_[i].melodic_;
- Context * origin = accidentals_[i].origin_;
+ Grob *support = accidentals_[i].head_;
+ Music *note = accidentals_[i].melodic_;
+ Context *origin = accidentals_[i].origin_;
- Pitch * pitch = unsmob_pitch (note->get_property ("pitch"));
+ Pitch *pitch = unsmob_pitch (note->get_property ("pitch"));
if (!pitch)
continue;
level, so that we get the property settings for
Accidental from the respective Voice.
*/
- Grob * a = make_item_from_properties (origin->implementation (),
- ly_symbol2scm ("Accidental"),
- note->self_scm ()
- );
+ Grob *a
+ = make_item_from_properties (origin->implementation (),
+ ly_symbol2scm ("Accidental"),
+ note->self_scm ());
a->set_parent (support, Y_AXIS);
if (!accidental_placement_)
- {
- accidental_placement_ = make_item ("AccidentalPlacement", a->self_scm ());
- }
-
+ accidental_placement_ = make_item ("AccidentalPlacement",
+ a->self_scm ());
Accidental_placement::add_accidental (accidental_placement_, a);
-
-
- SCM accs = scm_cons (scm_int2num (pitch->get_alteration ()), SCM_EOL);
+ SCM accs = scm_cons (scm_int2num (pitch->get_alteration ()),
+ SCM_EOL);
if (num == 2 && extra_natural_b)
accs = scm_cons (scm_int2num (0), accs);
- /* TODO:
-
- add cautionary option in accidental.
- */
+ /* TODO: add cautionary option in accidental. */
if (cautionary)
- {
- a->set_property ("cautionary", SCM_BOOL_T);
- }
-
+ a->set_property ("cautionary", SCM_BOOL_T);
support->set_property ("accidental-grob", a->self_scm ());
}
}
-
-
-
void
Accidental_engraver::finalize ()
{
void
Accidental_engraver::stop_translation_timestep ()
{
- for (int j = ties_.size (); j --; )
+ for (int j = ties_.size (); j--;)
{
- Grob * r = Tie::head (ties_[j], RIGHT);
+ Grob *r = Tie::head (ties_[j], RIGHT);
for (int i = accidentals_.size (); i--;)
if (accidentals_[i].head_ == r)
{
- if (Grob * g = accidentals_[i].accidental_)
+ if (Grob *g = accidentals_[i].accidental_)
{
g->set_property ("tie", ties_[j]->self_scm ());
- accidentals_[i].tied_ = true;
+ accidentals_[i].tied_ = true;
}
-
ties_.del (j);
break;
}
{
int barnum = get_bar_number ();
- Music * note = accidentals_[i].melodic_;
+ Music *note = accidentals_[i].melodic_;
Context * origin = accidentals_[i].origin_;
- Pitch * pitch = unsmob_pitch (note->get_property ("pitch"));
+ Pitch *pitch = unsmob_pitch (note->get_property ("pitch"));
if (!pitch)
continue;
-
+
int n = pitch->get_notename ();
int o = pitch->get_octave ();
int a = pitch->get_alteration ();
SCM key = scm_cons (scm_int2num (o), scm_int2num (n));
- while (origin && origin->where_defined (ly_symbol2scm ("localKeySignature")))
+ while (origin
+ && origin->where_defined (ly_symbol2scm ("localKeySignature")))
{
/*
huh? we set props all the way to the top?
not really really correct if there are more than one
noteheads with the same notename.
*/
- localsig = ly_assoc_front_x
- (localsig, key, scm_cons (scm_int2num (a), scm_int2num (barnum)));
-
+ localsig = ly_assoc_front_x (localsig, key,
+ scm_cons (scm_int2num (a),
+ scm_int2num (barnum)));
change = true;
}
if (change)
- origin->set_property ("localKeySignature", localsig);
-
+ origin->set_property ("localKeySignature", localsig);
+
origin = origin->get_parent_context ();
}
}
-
accidental_placement_ = 0;
-
accidentals_.clear ();
left_objects_.clear ();
right_objects_.clear ();
void
Accidental_engraver::acknowledge_grob (Grob_info info)
{
- Music * note = info.music_cause ();
+ Music *note = info.music_cause ();
if (note
&& note->is_mus_type ("note-event")
}
}
else if (Tie::has_interface (info.grob_))
- {
- ties_.push (dynamic_cast<Spanner*> (info.grob_));
- }
+ ties_.push (dynamic_cast<Spanner*> (info.grob_));
else if (Arpeggio::has_interface (info.grob_))
- {
- left_objects_.push (info.grob_);
- }
- else if (info.grob_->internal_has_interface (ly_symbol2scm ("finger-interface")))
- {
- left_objects_.push (info.grob_);
- }
+ left_objects_.push (info.grob_);
+ else if (info.grob_
+ ->internal_has_interface (ly_symbol2scm ("finger-interface")))
+ left_objects_.push (info.grob_);
}
void
Accidental_engraver::process_music ()
{
SCM sig = get_property ("keySignature");
-
/* Detect key sig changes.
- Update all parents and children
- */
+ Update all parents and children. */
if (last_keysig_ != sig)
- {
- update_local_key_signature ();
- }
+ update_local_key_signature ();
}
-
-
-
-
ENTER_DESCRIPTION (Accidental_engraver,
- "Make accidentals. Catches note heads, ties and notices key-change "
- "events. This engraver usually lives at Staff level, but "
+ "Make accidentals. "
+ "Catch note heads, ties and notices key-change events. "
+ "This engraver usually lives at Staff level, but "
"reads the settings for Accidental at @code{Voice} level, "
- "so you can @code{\\override} them at @code{Voice}. "
- ,
+ "so you can @code{\\override} them at @code{Voice}. ",
"Accidental",
+
"",
- "finger-interface rhythmic-head-interface tie-interface arpeggio-interface",
- "localKeySignature harmonicAccidentals extraNatural autoAccidentals autoCautionaries",
+
+ "arpeggio-interface ",
+ "autoAccidentals "
+ "autoCautionaries",
+ "finger-interface "
+ "rhythmic-head-interface "
+ "tie-interface "
+
+ "extraNatural "
+ "harmonicAccidentals "
+ "localKeySignature "
+
"localKeySignature");
Bar_engraver::process_acknowledged_grobs ()
{
if (!bar_ && ly_c_string_p (get_property ("whichBar")))
- {
- create_bar ();
- }
+ create_bar ();
}
void
Bar_engraver::typeset_bar ()
{
- bar_ =0;
+ bar_ = 0;
}
/*
Bar_engraver::stop_translation_timestep ()
{
if (!bar_)
- {
- get_score_engraver ()->forbid_breaks (); // guh. Use properties!
- }
+ /* guh. Use properties! */
+ get_score_engraver ()->forbid_breaks ();
else
typeset_bar ();
}
Global_context::apply_finalizations ()
{
SCM lst = get_property ("finalizations");
- set_property ("finalizations" , SCM_EOL);
- for (SCM s = lst ; ly_c_pair_p (s); s = ly_cdr (s))
- {
- scm_primitive_eval (ly_car (s)); // TODO: make safe.
- }
+ set_property ("finalizations", SCM_EOL);
+ for (SCM s = lst; ly_c_pair_p (s); s = ly_cdr (s))
+ /* TODO: make safe. */
+ scm_primitive_eval (ly_car (s));
}
-/*
- Add a function to execute before stepping to the next time step.
-*/
+/* Add a function to execute before stepping to the next time step. */
void
Global_context::add_finalization (SCM x)
{
SCM lst = get_property ("finalizations");
lst = scm_cons (x, lst);
- set_property ("finalizations" ,lst);
+ set_property ("finalizations", lst);
}
Moment
void
Grace_iterator::process (Moment m)
{
- Moment main ;
+ Moment main;
main.main_part_ = - start_mom_.grace_part_ + m.grace_part_;
Music_wrapper_iterator::process (main);
- /*
- We can safely do this, since \grace should always be inside
- sequential.
- */
+ /* We can safely do this, since \grace should always be inside
+ sequential. */
descend_to_child (child_iter_->get_outlet ());
}
typedef void (Grob::*Grob_method_pointer) (void);
+// looking at gtk+/pango docstrings .. WIP
-/* Basic G[raphical output] O[bject]. */
+/**
+ * Grob:
+ * @internal_get_property: get property #NAME.
+ *
+ * Class structure for #Grob.
+ **/
class Grob
{
+private:
+ DECLARE_SMOBS (Grob, foo);
+ void init ();
+
protected:
SCM immutable_property_alist_;
SCM mutable_property_alist_;
friend class Spanner;
- void substitute_mutable_properties(SCM,SCM);
+ void substitute_mutable_properties (SCM, SCM);
char status_;
+
public:
Grob *original_;
- /*
- TODO: junk this member.
- */
+ /* TODO: junk this member. */
Paper_score *pscore_;
+
Dimension_cache dim_cache_[NO_AXES];
Grob (SCM basic_props);
Grob (Grob const&);
- VIRTUAL_COPY_CONSTRUCTOR(Grob,Grob);
+ VIRTUAL_COPY_CONSTRUCTOR (Grob, Grob);
+ DECLARE_SCHEME_CALLBACK (stencil_extent, (SCM smob, SCM axis));
String name () const;
-
+
+
/*
- properties
+ Properties
*/
SCM internal_get_property (SCM) const;
void internal_set_property (SCM, SCM val);
void add_to_list_property (SCM, SCM);
- void warning (String)const;
- void programming_error (String)const;
+
+ SCM get_property_alist_chain (SCM) const;
+ static SCM ly_grob_set_property (SCM, SCM,SCM);
+ static SCM ly_grob_property (SCM, SCM);
+
+ void warning (String) const;
+ void programming_error (String) const;
Output_def *get_paper () const;
void add_dependency (Grob*);
virtual void discretionary_processing ();
virtual SCM do_derived_mark () const;
- Stencil * get_stencil () const;
+ Stencil *get_stencil () const;
SCM get_uncached_stencil () const;
- SCM get_property_alist_chain (SCM) const;
void suicide ();
bool is_live () const;
+ bool is_empty (Axis a) const;
- DECLARE_SCHEME_CALLBACK (stencil_extent, (SCM smob, SCM axis));
-
- static SCM ly_grob_set_property (SCM, SCM,SCM);
- static SCM ly_grob_property (SCM, SCM);
-
bool internal_has_interface (SCM intf);
- static bool has_interface (Grob*me);
+ static bool has_interface (Grob *me);
virtual void handle_broken_dependencies ();
virtual void handle_prebroken_dependencies ();
- DECLARE_SMOBS (Grob,foo);
-
- void init ();
-public:
- bool is_empty (Axis a) const;
-
Interval extent (Grob * refpoint, Axis) const;
void translate_axis (Real, Axis);
- Real relative_coordinate (Grob const* refp, Axis) const;
- Grob*common_refpoint (Grob const* s, Axis a) const;
+ Real relative_coordinate (Grob const *refp, Axis) const;
+ Grob *common_refpoint (Grob const *s, Axis a) const;
// duh. slim down interface here. (todo)
- bool has_offset_callback (SCM callback, Axis)const;
+ bool has_offset_callback (SCM callback, Axis) const;
void add_offset_callback (SCM callback, Axis);
- bool has_extent_callback (SCM, Axis)const;
- void set_extent (SCM , Axis);
+ bool has_extent_callback (SCM, Axis) const;
+ void set_extent (SCM, Axis);
Real get_offset (Axis a) const;
void set_parent (Grob* e, Axis);
- Grob *get_parent (Axis a) const { return dim_cache_[a].parent_; }
+
+ // URG
+ Grob *get_parent (Axis a) const
+ {
+ return dim_cache_[a].parent_;
+ }
DECLARE_SCHEME_CALLBACK (fixup_refpoint, (SCM));
};
-DECLARE_UNSMOB(Grob,grob);
-Spanner* unsmob_spanner (SCM );
-Item* unsmob_item (SCM );
+DECLARE_UNSMOB (Grob, grob);
+Spanner *unsmob_spanner (SCM);
+Item *unsmob_item (SCM);
-Grob*common_refpoint_of_list (SCM elt_list, Grob * , Axis a);
-Grob*common_refpoint_of_array (Link_array<Grob> const&, Grob * , Axis a);
+Grob *common_refpoint_of_list (SCM elt_list, Grob *, Axis a);
+Grob *common_refpoint_of_array (Link_array<Grob> const&, Grob *, Axis a);
void set_break_subsititution (SCM criterion);
SCM substitute_mutable_property_alist (SCM alist);
-Link_array<Grob> ly_scm2grobs (SCM l);
+Link_array<Grob> ly_scm2grobs (SCM ell);
SCM ly_grobs2scm (Link_array<Grob> a);
#endif /* GROB_HH */
{
if (ev->is_mus_type ("key-change-event"))
{
+ /* do this only once, just to be on the safe side. */
if (!key_ev_)
{
- /*
- do this only once, just to be on the safe side.
- */
key_ev_ = ev;
read_ev (key_ev_);
}
-
return true;
}
return false;
SCM mod = SCM_EOL;
if (!safe)
{
-
String s = "*anonymous-ly-" + to_string (module_count++) + "*";
mod = scm_c_define_module (s.to_str0 (), ly_init_anonymous_module, 0);
-
ly_use_module (mod, global_lily_module);
}
else
{
SCM proc = ly_scheme_function ("make-safe-lilypond-module");
-
mod = scm_call_0 (proc);
}
return mod;
SCM
My_lily_lexer::lookup_identifier (String name)
{
- return lookup_identifier_symbol ( ly_symbol2scm (name.to_str0 ()));
+ return lookup_identifier_symbol (ly_symbol2scm (name.to_str0 ()));
}
void
// yy_flex_debug = 1;
new_input (main_input_name_, sources_);
/* Do not allow \include in --safe-mode */
- allow_includes_b_ = allow_includes_b_ && ! safe_global_b;
+ allow_includes_b_ = allow_includes_b_ && !safe_global_b;
scm_module_define (ly_car (scopes_),
ly_symbol2scm ("input-file-name"),
SCM
internal_ly_parse_scm (Parse_start * ps)
{
- Source_file* sf =ps->start_location_.source_file_;
+ Source_file *sf =ps->start_location_.source_file_;
SCM port = sf->get_port ();
- int off = ps->start_location_.defined_str0_ - sf->to_str0();
+ int off = ps->start_location_.defined_str0_ - sf->to_str0 ();
scm_seek (port, scm_long2num (off), scm_long2num (SEEK_SET));
SCM from = scm_ftell (port);
SCM form;
SCM answer = SCM_UNSPECIFIED;
- /* Read expression from port */
+ /* Read expression from port. */
if (!SCM_EOF_OBJECT_P (form = scm_read (port)))
{
+ SCM function = ly_scheme_function ("make-safe-lilypond-module");
if (ps->safe_)
- answer = scm_eval (form,
- scm_call_0 (ly_scheme_function ("make-safe-lilypond-module")));
+ answer = scm_eval (form, function);
else
answer = scm_primitive_eval (form);
}
}
SCM
-parse_handler (void * data, SCM tag, SCM args)
+parse_handler (void *data, SCM tag, SCM args)
{
- Parse_start* ps = (Parse_start*) data;
- (void) tag; // prevent warning
+ Parse_start* ps = (Parse_start *) data;
+ (void) tag;
ps->start_location_.error (_("GUILE signaled an error for the expression beginning here"));
bool parse_protect_global = true;
-/* Try parsing. Upon failure return SCM_UNDEFINED. */
+/* Try parsing. Upon failure return SCM_UNDEFINED.
+ FIXME: shouldn't we return SCM_UNSCPECIFIED -- jcn */
SCM
-ly_parse_scm (char const* s, int *n, Input i, bool safe)
+ly_parse_scm (char const *s, int *n, Input i, bool safe)
{
- Parse_start ps ;
+ Parse_start ps;
ps.str = s;
ps.start_location_ = i;
ps.safe_ = safe;
#include "stem-tremolo.hh"
void
-Stem::set_beaming (Grob*me, int beam_count, Direction d)
+Stem::set_beaming (Grob *me, int beam_count, Direction d)
{
SCM pair = me->get_property ("beaming");
me->set_property ("beaming", pair);
}
- SCM l = index_get_cell (pair, d);
- for (int i = 0; i< beam_count; i++)
- {
- l = scm_cons (scm_int2num (i), l);
- }
- index_set_cell (pair, d, l);
+ SCM lst = index_get_cell (pair, d);
+ for (int i = 0; i < beam_count; i++)
+ lst = scm_cons (scm_int2num (i), lst);
+ index_set_cell (pair, d, lst);
}
-
Interval
-Stem::head_positions (Grob*me)
+Stem::head_positions (Grob *me)
{
- if (!head_count (me))
+ if (head_count (me))
{
- Interval iv;
- return iv;
+ Drul_array<Grob*> e (extremal_heads (me));
+ return Interval (Staff_symbol_referencer::get_position (e[DOWN]),
+ Staff_symbol_referencer::get_position (e[UP]));
}
-
- Drul_array<Grob*> e (extremal_heads (me));
-
- return Interval (Staff_symbol_referencer::get_position (e[DOWN]),
- Staff_symbol_referencer::get_position (e[UP]));
+ return Interval ();
}
-
Real
Stem::chord_start_y (Grob *me)
{
Interval hp = head_positions (me);
- if (hp.is_empty ())
- return 0;
- return hp[get_direction (me)] * Staff_symbol_referencer::staff_space (me)
- * 0.5;
+ if (!hp.is_empty ())
+ return hp[get_direction (me)] * Staff_symbol_referencer::staff_space (me)
+ * 0.5;
+ return 0;
}
Real
if (!d)
{
- d = get_default_dir (me);
- // urg, AAARGH!
- set_grob_direction (me, d);
+ d = get_default_dir (me);
+ // urg, AAARGH!
+ set_grob_direction (me, d);
}
return d;
}
Stem::set_stemend (Grob *me, Real se)
{
// todo: margins
- Direction d= get_direction (me);
+ Direction d = get_direction (me);
if (d && d * head_positions (me)[get_direction (me)] >= se*d)
me->warning (_ ("Weird stem size; check for narrow beams"));
/* Note head that determines hshift for upstems
WARNING: triggers direction */
-Grob*
+Grob *
Stem::support_head (Grob *me)
{
if (head_count (me) == 1)
}
int
-Stem::head_count (Grob*me)
+Stem::head_count (Grob *me)
{
- return Pointer_group_interface::count (me, "note-heads");
+ return Pointer_group_interface::count (me, "note-heads");
}
/* The note head which forms one end of the stem.
WARNING: triggers direction */
-Grob*
+Grob *
Stem::first_head (Grob *me)
{
Direction d = get_direction (me);
- if (!d)
- return 0;
- return extremal_heads (me)[-d];
+ if (d)
+ return extremal_heads (me)[-d];
+ return 0;
}
/* The note head opposite to the first head. */
-Grob*
+Grob *
Stem::last_head (Grob *me)
{
Direction d = get_direction (me);
- if (!d)
- return 0;
- return extremal_heads (me)[d];
+ if (d)
+ return extremal_heads (me)[d];
+ return 0;
}
/* START is part where stem reaches `last' head. */
Drul_array<Grob *> exthead;
exthead[LEFT] = exthead[RIGHT] =0;
- for (SCM s = me->get_property ("note-heads"); ly_c_pair_p (s); s = ly_cdr (s))
+ for (SCM s = me->get_property ("note-heads"); ly_c_pair_p (s);
+ s = ly_cdr (s))
{
Grob *n = unsmob_grob (ly_car (s));
int p = Staff_symbol_referencer::get_rounded_position (n);
Direction d = LEFT;
do
{
- if (d* p > d* extpos[d])
+ if (d * p > d * extpos[d])
{
exthead[d] = n;
extpos[d] = p;
Stem::note_head_positions (Grob *me)
{
Array<int> ps ;
- for (SCM s = me->get_property ("note-heads"); ly_c_pair_p (s); s = ly_cdr (s))
+ for (SCM s = me->get_property ("note-heads"); ly_c_pair_p (s);
+ s = ly_cdr (s))
{
- Grob * n = unsmob_grob (ly_car (s));
+ Grob *n = unsmob_grob (ly_car (s));
int p = Staff_symbol_referencer::get_rounded_position (n);
ps.push (p);
}
Real
-Stem::get_default_stem_end_position (Grob*me)
+Stem::get_default_stem_end_position (Grob *me)
{
Real ss = Staff_symbol_referencer::staff_space (me);
int durlog = duration_log (me);
{
s = me->get_property ("lengths");
if (ly_c_pair_p (s))
- length = 2* ly_scm2double (robust_list_ref (durlog -2, s));
+ length = 2 * ly_scm2double (robust_list_ref (durlog - 2, s));
}
/* URGURGURG
if (durlog >= 3)
{
- Interval flag_ext = flag (me).extent (Y_AXIS) ;
+ Interval flag_ext = flag (me).extent (Y_AXIS);
if (!flag_ext.is_empty ())
- minlen += 2 * flag_ext.length () / ss ;
+ minlen += 2 * flag_ext.length () / ss;
/* The clash is smaller for down stems (since the tremolo is
angled up.) */
if (dots)
{
Real dp = Staff_symbol_referencer::get_position (dots);
- Real flagy = flag (me).extent (Y_AXIS)[-dir] * 2
- / ss;
+ Real flagy = flag (me).extent (Y_AXIS)[-dir] * 2 / ss;
/* Very gory: add myself to the X-support of the parent,
which should be a dot-column. */
return st;
}
-
-
-/*
-
- the log of the duration (Number of hooks on the flag minus two)
- */
+/* The log of the duration (Number of hooks on the flag minus two) */
int
-Stem::duration_log (Grob*me)
+Stem::duration_log (Grob *me)
{
SCM s = me->get_property ("duration-log");
return (ly_c_number_p (s)) ? ly_scm2int (s) : 2;
}
void
-Stem::position_noteheads (Grob*me)
+Stem::position_noteheads (Grob *me)
{
if (!head_count (me))
return;
Link_array<Grob> heads =
- Pointer_group_interface__extract_grobs (me, (Grob*)0, "note-heads");
+ Pointer_group_interface__extract_grobs (me, (Grob*) 0, "note-heads");
heads.sort (compare_position);
Direction dir =get_direction (me);
if (dir < 0)
heads.reverse ();
-
Real thick = thickness (me);
Grob *hed = support_head (me);
Real w = Note_head::head_extent (hed,X_AXIS)[dir];
- for (int i=0; i < heads.size (); i++)
- {
- heads[i]->translate_axis (w - Note_head::head_extent (heads[i], X_AXIS)[dir],
- X_AXIS);
- }
+ for (int i = 0; i < heads.size (); i++)
+ heads[i]->translate_axis (w - Note_head::head_extent (heads[i],
+ X_AXIS)[dir],
+ X_AXIS);
- bool parity= true;
+ bool parity = true;
Real lastpos = Real (Staff_symbol_referencer::get_position (heads[0]));
- for (int i=1; i < heads.size (); i ++)
+ for (int i = 1; i < heads.size (); i ++)
{
Real p = Staff_symbol_referencer::get_position (heads[i]);
Real dy =fabs (lastpos- p);
{
if (parity)
{
- Real l = Note_head::head_extent (heads[i], X_AXIS).length ();
+ Real ell = Note_head::head_extent (heads[i], X_AXIS).length ();
Direction d = get_direction (me);
/*
- Reversed head should be shifted l-thickness, but this
- looks too crowded, so we only shift l-0.5*thickness.
+ Reversed head should be shifted ell-thickness, but this
+ looks too crowded, so we only shift ell-0.5*thickness.
This leads to assymetry: Normal heads overlap the
stem 100% whereas reversed heads only overlaps the
stem 50%
-
*/
- Real reverse_overlap =0.5;
- heads[i]->translate_axis ((l-thick*reverse_overlap) * d, X_AXIS);
+ Real reverse_overlap = 0.5;
+ heads[i]->translate_axis ((ell - thick * reverse_overlap) * d,
+ X_AXIS);
if (is_invisible (me))
- heads[i]->translate_axis (-thick*(2 - reverse_overlap) * d , X_AXIS);
+ heads[i]->translate_axis (-thick * (2 - reverse_overlap) * d,
+ X_AXIS);
-
/* TODO:
For some cases we should kern some more: when the
SCM
Stem::before_line_breaking (SCM smob)
{
- Grob*me = unsmob_grob (smob);
-
+ Grob *me = unsmob_grob (smob);
/*
Do the calculations for visible stems, but also for invisible stems
position_noteheads (me);
}
else
- {
- me->set_property ("print-function", SCM_EOL);
- }
-
+ me->set_property ("print-function", SCM_EOL);
+
return SCM_UNSPECIFIED;
}
Stem::height (SCM smob, SCM ax)
{
Axis a = (Axis)ly_scm2int (ax);
- Grob * me = unsmob_grob (smob);
+ Grob *me = unsmob_grob (smob);
assert (a == Y_AXIS);
SCM mol = me->get_uncached_stencil ();
Stencil
-Stem::flag (Grob*me)
+Stem::flag (Grob *me)
{
/* TODO: maybe property stroke-style should take different values,
e.g. "" (i.e. no stroke), "single" and "double" (currently, it's
SCM flag_style_scm = me->get_property ("flag-style");
if (ly_c_symbol_p (flag_style_scm))
- {
- flag_style = ly_symbol2string (flag_style_scm);
- }
-
+ flag_style = ly_symbol2string (flag_style_scm);
+
if (flag_style == "no-flag")
- {
- return Stencil ();
- }
+ return Stencil ();
bool adjust = true;
--hwn.
*/
int p = Staff_symbol_referencer::get_rounded_position (me);
- staffline_offs = Staff_symbol_referencer::on_staffline (me, p) ?
- "1" : "0";
+ staffline_offs = Staff_symbol_referencer::on_staffline (me, p)
+ ? "1" : "0";
}
else
{
}
char dir = (get_direction (me) == UP) ? 'u' : 'd';
- String font_char =
- flag_style + to_string (dir) + staffline_offs + to_string (duration_log (me));
+ String font_char = flag_style
+ + to_string (dir) + staffline_offs + to_string (duration_log (me));
Font_metric *fm = Font_interface::get_default_font (me);
Stencil flag = fm->find_by_name ("flags-" + font_char);
if (flag.is_empty ())
- {
- me->warning (_f ("flag `%s' not found", font_char));
- }
+ me->warning (_f ("flag `%s' not found", font_char));
SCM stroke_style_scm = me->get_property ("stroke-style");
if (ly_c_string_p (stroke_style_scm))
String font_char = to_string (dir) + stroke_style;
Stencil stroke = fm->find_by_name ("flags-" + font_char);
if (stroke.is_empty ())
- {
- me->warning (_f ("flag stroke `%s' not found", font_char));
- }
+ me->warning (_f ("flag stroke `%s' not found", font_char));
else
- {
- flag.add_stencil (stroke);
- }
+ flag.add_stencil (stroke);
}
}
if (unsmob_grob (me->get_property ("beam")) || abs (duration_log (me)) <= 2)
; // TODO!
else
- {
- r = flag (me).extent (X_AXIS)
- + thickness (me)/2;
- }
+ r = flag (me).extent (X_AXIS)
+ + thickness (me)/2;
return ly_interval2scm (r);
}
Real
-Stem::thickness (Grob* me)
+Stem::thickness (Grob *me)
{
return ly_scm2double (me->get_property ("thickness"))
* Staff_symbol_referencer::line_thickness (me);
}
-MAKE_SCHEME_CALLBACK (Stem,print,1);
-
+MAKE_SCHEME_CALLBACK (Stem, print, 1);
SCM
Stem::print (SCM smob)
{
- Grob*me = unsmob_grob (smob);
+ Grob *me = unsmob_grob (smob);
Stencil mol;
Direction d = get_direction (me);
- /*
- TODO: make the stem start a direction ?
-
- This is required to avoid stems passing in tablature chords...
- */
+ /* TODO: make the stem start a direction ?
+ This is required to avoid stems passing in tablature chords. */
Grob *lh = to_boolean (me->get_property ("avoid-note-head"))
? last_head (me) : lh = first_head (me);
Interval stem_y (y1 <? y2,y2 >? y1);
-
// dy?
Real dy = Staff_symbol_referencer::staff_space (me) * 0.5;
/*
move the stem to right of the notehead if it is up.
*/
-MAKE_SCHEME_CALLBACK (Stem,off_callback,2);
+MAKE_SCHEME_CALLBACK (Stem, off_callback, 2);
SCM
Stem::off_callback (SCM element_smob, SCM)
{
Grob *me = unsmob_grob (element_smob);
-
- Real r=0;
-
- if (head_count (me) == 0)
- {
- return scm_make_real (0.0);
- }
-
- if (Grob * f = first_head (me))
- {
- Interval head_wid = Note_head::head_extent (f, X_AXIS);
-
- Real attach =0.0;
-
- if (is_invisible (me))
- {
+ Real r = 0.0;
+
+ if (head_count (me))
+ if (Grob *f = first_head (me))
+ {
+ Interval head_wid = Note_head::head_extent (f, X_AXIS);
+ Real attach = 0.0;
+
+ if (is_invisible (me))
attach = 0.0;
- }
- else
+ else
attach = Note_head::stem_attachment_coordinate (f, X_AXIS);
-
- Direction d = get_direction (me);
-
- Real real_attach = head_wid.linear_combination (d * attach);
-
- r = real_attach;
-
- /*
- If not centered: correct for stem thickness.
- */
- if (attach)
- {
- Real rule_thick
- = thickness (me);
- r += - d * rule_thick * 0.5;
- }
- }
+ Direction d = get_direction (me);
+ Real real_attach = head_wid.linear_combination (d * attach);
+ r = real_attach;
+
+ /* If not centered: correct for stem thickness. */
+ if (attach)
+ {
+ Real rule_thick = thickness (me);
+ r += - d * rule_thick * 0.5;
+ }
+ }
return scm_make_real (r);
}
-
-Grob*
-Stem::get_beam (Grob*me)
+Grob *
+Stem::get_beam (Grob *me)
{
- SCM b= me->get_property ("beam");
+ SCM b = me->get_property ("beam");
return unsmob_grob (b);
}
/* FIXME: Too many properties */
-ADD_INTERFACE (Stem,"stem-interface",
- "The stem represent the graphical stem. "
- " In addition, it internally connects note heads, beams, tremolos. Rests "
- " and whole notes have invisible stems.",
+ADD_INTERFACE (Stem, "stem-interface",
+ "The stem represent the graphical stem. "
+ "In addition, it internally connects note heads, beams and"
+ "tremolos. "
+ "Rests and whole notes have invisible stems.",
"tremolo-flag french-beaming "
"avoid-note-head thickness "
"stem-info beamed-lengths beamed-minimum-free-lengths "
"note-heads direction length flag-style "
"no-stem-extend stroke-style");
-
-
/****************************************************************/
Stem_info::Stem_info ()
{
- ideal_y_ = shortest_y_ =0;
+ ideal_y_ = shortest_y_ = 0;
dir_ = CENTER;
}
*/
class Time_signature_engraver : public Engraver
{
- Item * time_signature_;
+ Item *time_signature_;
SCM last_time_fraction_;
protected:
Time_signature_engraver::Time_signature_engraver ()
{
- time_signature_ =0;
+ time_signature_ = 0;
last_time_fraction_ = SCM_BOOL_F;
}
/*
not rigorously safe, since the value might get GC'd and
reallocated in the same spot */
- SCM fr= get_property ("timeSignatureFraction");
+ SCM fr = get_property ("timeSignatureFraction");
if (!time_signature_
&& last_time_fraction_ != fr
&& ly_c_pair_p (fr))
void
Time_signature_engraver::stop_translation_timestep ()
{
- time_signature_ =0;
+ time_signature_ = 0;
}
;;;;
;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
-(define-module (scm framework-gnome)
- :use-module (oop goops)
- #:export (<gnome-outputter>))
+;;;; See output-gnome.scm for usage information.
-;;(define this-module (current-module))
+
+(define-module (scm framework-gnome))
(use-modules (guile) (oop goops) (lily))
(use-modules
+ (ice-9 regex)
(gnome gtk)
- (gnome gtk gdk-event)
- ;;
- (scm output-gnome)
- )
+ (gnome gtk gdk-event))
;; the name of the module will change to canvas rsn
(if (resolve-module '(gnome gw canvas))
(use-modules (gnome gw canvas))
(use-modules (gnome gw libgnomecanvas)))
-
(define-public (output-framework-gnome outputter book scopes fields basename)
- ;;(gnome-main book))))
- (ly:outputter-dump-stencil
- outputter
- (ly:make-stencil (list 'gnome-main book) '(0 . 0) '(0 . 0))))
+ (if #t
+ (gnome-main book)
+ (ly:outputter-dump-stencil
+ outputter
+ (ly:make-stencil (list 'gnome-main book) '(0 . 0) '(0 . 0)))))
+
+;; WTF? -- jcn
+;; Yay, I *finally* found it!
+(define-public output-framework output-framework-gnome)
+
+(define SCROLLBAR-SIZE 20)
+(define BUTTON-HEIGHT 25)
+(define PANELS-HEIGHT 80)
+
+(define PIXELS-PER-UNIT 2)
+(define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT))
+(define-public output-scale OUTPUT-SCALE)
+
+(define (stderr string . rest)
+ ;; debugging
+ (if #f
+ (begin
+ (apply format (cons (current-error-port) (cons string rest)))
+ (force-output (current-error-port)))))
+
+(define-class <gnome-outputter> ()
+ (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)
+ (location #:init-value #f #:accessor location)
+ (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
+ (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* ((button (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 button (quotient (window-width go) 2) BUTTON-HEIGHT)
+
+
+ (add hbox next)
+ (add hbox prev)
+ (add hbox button)
+
+ ;; signals
+ (gtype-instance-signal-connect
+ button 'clicked (lambda (b) (gtk-main-quit)))
+ (gtype-instance-signal-connect
+ next 'clicked (lambda (b) (dump-page go (1+ (page-number go)))))
+ (gtype-instance-signal-connect
+ prev 'clicked (lambda (b) (dump-page go (1- (page-number go)))))
+ (gtype-instance-signal-connect
+ (window go) 'key-press-event key-press-event)
+
+ (show-all (window go))))
+
+
+(define-public global-go #f)
+
+(define (gnome-main book)
+ (let* ((book-paper (ly:paper-book-book-paper book))
+ (hsize (ly:output-def-lookup book-paper 'hsize))
+ (vsize (ly:output-def-lookup book-paper 'vsize))
+ (page-width (inexact->exact (ceiling (* OUTPUT-SCALE hsize))))
+ (page-height (inexact->exact (ceiling (* OUTPUT-SCALE vsize))))
+ ;;(page-width (inexact->exact (ceiling hsize)))
+ ;;(page-height (inexact->exact (ceiling vsize)))
+
+ (screen-width (gdk-screen-width))
+ (screen-height (gdk-screen-height))
+ (desktop-height (- screen-height PANELS-HEIGHT))
+
+ (go (make <gnome-outputter>
+ #:page-stencils (list->vector (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.
+ (initialize go)
+
+ (dump-page go 0)
+
+ ;; ugh
+ (set! global-go go)
+
+ (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?
+ ;;(map destroy (gtk-container-get-children main-canvas))
+ ;;(map destroy text-items)
+
+ (set! (text-items go) '())
+ (stderr "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 x-editor #f)
+(define (get-x-editor)
+ (if (not x-editor)
+ (set! x-editor (getenv "XEDITOR")))
+ x-editor)
+
+(define ifs #f)
+(define (get-ifs)
+ (if (not ifs)
+ (set! ifs (getenv "IFS")))
+ (if (not ifs)
+ (set! ifs " "))
+ ifs)
+
+(define (spawn-editor location)
+ (let* ((line (car location))
+ (column (cadr location))
+ (file-name (caddr location))
+ (template (substring (get-x-editor) 0))
+
+ ;; Adhere to %l %c %f?
+ (command
+ (regexp-substitute/global
+ #f "%l" (regexp-substitute/global
+ #f "%c"
+ (regexp-substitute/global
+ #f "%f" template 'pre file-name 'post)
+ 'pre (number->string column)
+ 'post)
+ 'pre (number->string line) 'post)))
+
+ (stderr "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 (item-event item event . data)
+(define-public (item-event item event . data)
+ (case (gdk-event:type event)
+ ((enter-notify) (gobject-set-property item 'fill-color "red"))
+ ((leave-notify) (gobject-set-property item 'fill-color "black"))
+ ((button-press)
+
+ ;;FIXME
+ (let ((location (hashq-ref (item-locations global-go) item #f)))
+
+ (if location
+ (location-callback location)
+ (stderr "no location\n"))))
+ ((2button-press) (gobject-set-property item 'fill-color "red")))
+ #t)
+
+(define (scale-canvas factor)
+ (set! pixels-per-unit (* pixels-per-unit factor))
+ (set-pixels-per-unit main-canvas pixels-per-unit)
+ (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))
+
+(define (key-press-event item event . data)
+ (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 #t ;;(null? mods)
+ (eq? keyval gdk:plus))
+ (scale-canvas 2))
+ ((and #t ;; (null? mods)
+ (eq? keyval gdk:minus))
+ (scale-canvas 0.5))
+ ((or (eq? keyval gdk:Page-Up)
+ (eq? keyval gdk:BackSpace))
+ ;;FIXME
+ (dump-page global-go (1- (page-number global-go))))
+ ((or (eq? keyval gdk:Page-Down)
+ (eq? keyval gdk:space))
+ ;;FIXME
+ (dump-page global-go (1+ (page-number global-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
+ ((and (pair? result)
+ (eq? (car result) 'location))
+ (set! (location go) (cdr result)))
+ ((is-a? result <gnome-canvas-item>)
+ (gtype-instance-signal-connect result 'event item-event)
+ (if (location go)
+ (hashq-set! (item-locations go) result (location go)))))))
+
;; output
+;;(define-public (output-framework) (write "hello\n"))
+
(define output-tex-module
(make-module 1021 (list (resolve-interface '(scm output-tex)))))
(define output-ps-module
(define-public (ps-output-expression expr port)
(display (eval expr output-ps-module) port))
+;; TODO: generate this list by registering the stencil expressions
+;; stencil expressions should have docstrings.
+(define-public (ly:all-stencil-expressions)
+ "Return list of stencil expressions."
+ '(
+ beam
+ bezier-sandwich
+ blank
+ bracket
+ char
+ dashed-line
+ dashed-slur
+ dot
+ draw-line
+ ez-ball
+ filledbox
+ horizontal-line
+ polygon
+ repeat-slash
+ round-filled-box
+ symmetric-x-triangle
+ text
+ tuplet
+ zigzag-line
+ ))
+;; TODO: generate this list by registering the output-backend-commands
+;; output-backend-commands should have docstrings.
+(define-public (ly:all-output-backend-commands)
+ "Return list of output backend commands."
+ '(
+ comment
+ define-origin
+ no-origin
+ placebox
+ unknown
+ ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other files.
" ")
"\n")))
protects))
- outfile)
+ outfile)))
- ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (lilypond-main files)
- "Entry point for Lilypond"
- (let*
- ((failed '())
- (handler (lambda (key arg)
- (set! failed (cons arg failed))))
- )
-
+ "Entry point for LilyPond."
+ (let* ((failed '())
+ (handler (lambda (key arg) (set! failed (cons arg failed)))))
(for-each
- (lambda (fn)
- (catch 'ly-file-failed
- (lambda () (ly:parse-file fn))
- handler))
-
- files)
+ (lambda (f) (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler))
+ files)
(if (pair? failed)
(begin
- (display (string-append "\n *** Failed files: " (string-join failed) "\n" ))
+ (display
+ (string-append "\n *** Failed files: " (string-join failed) "\n"))
(exit 1))
- (exit 0))
-
- ))
-
+ (exit 0))))
lilypond-bin -fgnome input/simple-song.ly
"
-
;;; TODO:
;;; * pango+feta font (see archives gtk-i18n-list@gnome.org and
;;; lilypond-devel)
;;; * implement missing stencil functions
;;; * implement missing commands
;;; * user-interface, keybindings
-;;; * cleanups: (too many) global vars
;;; * papersize, outputscale from book
;;; SCRIPT moved to buildscripts/guile-gnome.sh
-(debug-enable 'backtrace)
-;;(define-module (scm output-gnome))
-(define-module (scm output-gnome)
- #:export (
- char
- comment
- define-origin
- filledbox
- horizontal-line
- no-origin
- placebox
- round-filled-box
- text
- ))
+(debug-enable 'backtrace)
+(define-module (scm output-gnome))
(define this-module (current-module))
(use-modules
(guile)
- (ice-9 regex)
(srfi srfi-13)
(lily)
- (gnome gtk)
- (gnome gtk gdk-event)
-
- ;; Hmm, <gnome-outputter> is not imported -- but trying this breaks
- ;; framework-gnome in a weird way.
- ;;(scm framework-gnome))
- )
+ (gnome gtk))
;; the name of the module will change to canvas rsn
(if (resolve-module '(gnome gw canvas))
(use-modules (gnome gw canvas))
(use-modules (gnome gw libgnomecanvas)))
-;; ughughughughu ughr huh?? -- defined in framework-gnome
-(define PIXELS-PER-UNIT 2)
-(define-class <gnome-outputter> ()
- (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)
- (location #:init-value #:f #:accessor location)
- (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
- (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 (dummy . foo) #f)
-
-;; minimal intercept list:
-(define output-interface-intercept
- '(comment
- define-origin
- no-origin))
-
-(map (lambda (x) (module-define! this-module x dummy))
- output-interface-intercept)
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; globals
+(define system-origin '(0 . 0))
-;;; output-scale and font-size fun
-;; This used to be:
-(define USED-TO-BE-OUTPUT-SCALE 2.83464566929134)
-;; However, it seems that we currently have:
-(define 2.3.4-OUTPUT-SCALE 1.75729901757299)
-;; to go from ly-units to <MM/points/whatever?>
-;; Hmm, is this the source of font size problems wrt titling's right margin?
-
-;;(define pixels-per-unit 1.0)
-;;(define ARBITRARY-OUTPUT-SCALE 5)
-
-;; Anyway, for on-screen this does not matter: 2 * 2.5 looks fine
-(define pixels-per-unit 2.0)
-(define ARBITRARY-OUTPUT-SCALE 2.5)
-
-;;(define output-scale (* OUTPUT-SCALE pixels-per-unit))
-(define output-scale (* ARBITRARY-OUTPUT-SCALE pixels-per-unit))
-
+;;; set by framework-gnome.scm:
+(define canvas-root #f)
+(define output-scale #f)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; helper functions
-;; helper functions -- sort this out
(define (stderr string . rest)
;; debugging
(if #f
(define (draw-rectangle x1 y1 x2 y2 color width-units)
(make <gnome-canvas-rect>
- #:parent (root (canvas global-go)) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
+ #:parent (canvas-root) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
#:fill-color color #:width-units width-units))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; stencil outputters
-;;;;
+;;; stencil outputters
+;;;
+
+(define (dummy . foo) #f)
+
+(map (lambda (x) (module-define! this-module x dummy))
+ (append
+ (ly:all-stencil-expressions)
+ (ly:all-output-backend-commands)))
(define (char font i)
(text font (utf8 i)))
-(define system-origin '(0 . 0))
(define (placebox x y expr)
(stderr "item: ~S\n" expr)
(let ((item expr))
(* output-scale (+ (car system-origin) x))
(* output-scale (- (car system-origin) y)))
(affine-relative item output-scale 0 0 output-scale 0 0)
-
- (gtype-instance-signal-connect item 'event item-event)
- (if (location global-go)
- (hashq-set! (item-locations global-go) item (location global-go)))
item)
#f)))
(stderr "pango-font-name: ~S\n" (pango-font-name font))
(stderr "pango-font-size: ~S\n" (pango-font-size font))
- (let ((item
- (make <gnome-canvas-text>
- #:parent (root (canvas global-go))
-
- ;; experimental text placement corrections.
- ;; UGHR? What happened to tex offsets? south-west?
- ;; is pango doing something 'smart' wrt baseline ?
- #:anchor 'south-west
- #:x 0.003 #:y 0.123
-
- ;;
- ;;#:anchor 'west
- ;;#:x 0.015 #:y -3.71
-
- #:font (pango-font-name font)
-
- #:size-points (pango-font-size font)
- ;;#:size ...
- #:size-set #t
-
- ;;apparently no effect :-(
- ;;#:scale 1.0
- ;;#:scale-set #t
-
- #:fill-color "black"
- #:text string)))
- (set! (text-items global-go) (cons item (text-items global-go)))
- item))
+
+ (make <gnome-canvas-text>
+ #:parent (canvas-root)
+
+ ;; experimental text placement corrections.
+ ;; UGHR? What happened to tex offsets? south-west?
+ ;; is pango doing something 'smart' wrt baseline ?
+ #:anchor 'south-west
+ #:x 0.003 #:y 0.123
+
+ ;;#:anchor 'west
+ ;;#:x 0.015 #:y -3.71
+
+ #:font (pango-font-name font)
+
+ #:size-points (pango-font-size font)
+ ;;#:size ...
+ #:size-set #t
+
+ ;;apparently no effect :-(
+ ;;#:scale 1.0
+ ;;#:scale-set #t
+
+ #:fill-color "black"
+ #:text string))
(define (filledbox a b c d)
(round-filled-box a b c d 0.001))
;;(let ((thickness 2))
(filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
-;; origin -- bad name
(define (define-origin file line col)
- ;; ughr, why is this not passed as [part of] stencil object
- (set! (location global-go) (if (procedure? point-and-click)
- ;; duh, only silly string append
- ;; (point-and-click line col file)
- (list line col file)
- #f)))
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; gnome stuff --- move to framework-gnome
-;;(define (dump-page (go <gnome-outputter>) number)
-
-
-
-(define SCROLLBAR-SIZE 20)
-(define BUTTON-HEIGHT 25)
-(define PANELS-HEIGHT 80)
-
-(define PIXELS-PER-UNIT 2)
-(define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT))
-
-;; helper functions -- sort this out
-(define (stderr string . rest)
- ;; debugging
- (if #t
- (begin
- (apply format (cons (current-error-port) (cons string rest)))
- (force-output (current-error-port)))))
-
-
-;; Hmm, actually, the only vars really needed by output-gnome are
-;; * (root (canvas go))
-;; * location
-;; * item-locations
-;; * pixels-per-unit
-;; * text-items
-;;
-;; so this class could be split in two parts / records?
-(define-class <gnome-outputter> ()
- (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)
- (location #:init-value #:f #:accessor location)
- (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
- (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>))
-;; )
-
-
-(define (gnome-main book)
- (let* ((book-paper (ly:paper-book-book-paper book))
- (hsize (ly:output-def-lookup book-paper 'hsize))
- (vsize (ly:output-def-lookup book-paper 'vsize))
- (page-width (inexact->exact (ceiling (* OUTPUT-SCALE hsize))))
- (page-height (inexact->exact (ceiling (* OUTPUT-SCALE vsize))))
- ;;(page-width (inexact->exact (ceiling hsize)))
- ;;(page-height (inexact->exact (ceiling vsize)))
-
- (screen-width (gdk-screen-width))
- (screen-height (gdk-screen-height))
- (desktop-height (- screen-height PANELS-HEIGHT))
-
- (go (make <gnome-outputter>
- #:page-stencils (list->vector (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))))
-
- (setup go)
- (dump-page go 0)
- (gtk-main)))
-
-(define (setup go)
- (let* ((button (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))
-
- (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?
- ;;(set-child-packing vbox hbox #f #f 0 'end)
- ;;(set-child-packing hbox button #f #f 0 'end)
-
- (set-size-request button (quotient (window-width go) 2) BUTTON-HEIGHT)
- (add hbox next)
- (add hbox prev)
- (add hbox button)
-
- ;; signals
- (gtype-instance-signal-connect
- button 'clicked (lambda (b) (gtk-main-quit)))
- (gtype-instance-signal-connect
- next 'clicked (lambda (b) (dump-page go (1+ (page-number go)))))
- (gtype-instance-signal-connect
- prev 'clicked (lambda (b) (dump-page go (1- (page-number go)))))
- (gtype-instance-signal-connect
- (window go) 'key-press-event key-press-event)
-
- (show-all (window go))))
-
-(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?
- ;;(map destroy (gtk-container-get-children main-canvas))
- ;;(map destroy text-items)
-
- ;;Hmm
- ;;(set! main-canvas canvas)
- (set! (text-items go) '())
- ;;(ly:outputter-dump-stencil (outputter go)
- ;; (vector-ref page-stencils page-number))
-
- (stderr "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))
- ;; ;;(lambda (x) (gnome-output-expression go x)) '(0 . 0))
-
- (if old-canvas (destroy old-canvas))
- (add (scrolled go) (canvas go))
- (show (canvas go)))))
-
-(define x-editor #f)
-(define (get-x-editor)
- (if (not x-editor)
- (set! x-editor (getenv "XEDITOR")))
- x-editor)
-
-(define ifs #f)
-(define (get-ifs)
- (if (not ifs)
- (set! ifs (getenv "IFS")))
- (if (not ifs)
- (set! ifs " "))
- ifs)
-
-(define (spawn-editor location)
- (let* ((line (car location))
- (column (cadr location))
- (file-name (caddr location))
- (template (substring (get-x-editor) 0))
-
- ;; Adhere to %l %c %f?
- (command
- (regexp-substitute/global
- #f "%l" (regexp-substitute/global
- #f "%c"
- (regexp-substitute/global
- #f "%f" template 'pre file-name 'post)
- 'pre (number->string column)
- 'post)
- 'pre (number->string line) 'post)))
-
- (stderr "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 (item-event item event . data)
- (case (gdk-event:type event)
- ((enter-notify) (gobject-set-property item 'fill-color "red"))
- ((leave-notify) (gobject-set-property item 'fill-color "black"))
- ((button-press)
- (let ((location (hashq-ref item-locations item #f)))
- (if location
- (location-callback location)
- (stderr "no location\n"))))
- ((2button-press) (gobject-set-property item 'fill-color "red")))
- #t)
-
-(define (scale-canvas factor)
- (set! pixels-per-unit (* pixels-per-unit factor))
- (set-pixels-per-unit main-canvas pixels-per-unit)
- (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))
-
-(define (key-press-event item event . data)
- (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 #t ;;(null? mods)
- (eq? keyval gdk:plus))
- (scale-canvas 2))
- ((and #t ;; (null? mods)
- (eq? keyval gdk:minus))
- (scale-canvas 0.5))
- ((or (eq? keyval gdk:Page-Up)
- (eq? keyval gdk:BackSpace))
- (dump-page (1- page-number)))
- ((or (eq? keyval gdk:Page-Down)
- (eq? keyval gdk:space))
- (dump-page (1+ page-number))))
- #f))
-
-;;(define (new-canvas go <gnome-outputter>)
-(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
-;; ;;(make-module 1021 (list (resolve-interface '(scm output-gnome)))))
-;; this-module)
-
-(define global-go #f)
-
-(define-public (gnome-output-expression go expr)
- (stderr "HI\n")
- (set! global-go go)
- (eval expr this-module))
-
-
+ (if (procedure? point-and-click)
+ ;; duh, only silly string append
+ ;; (point-and-click line col file)
+ (list 'location line col file)
+ #f))
(define-module (scm output-ps)
#:re-export (quote)
+
+ ;; FIXME
+ ;;; <unnamed port>: Wrong type argument in position 2 (expecting SYMBOLP): (append (ly:all-stencil-expressions) (ly:all-output-backend-commands))
+ ;;#:export ,(append (ly:all-stencil-expressions)
+ ;; (ly:all-output-backend-commands)))
+
+; ;; UGHXr
#:export (unknown
blank
dot
no-origin
))
+
(use-modules (guile)
(ice-9 regex)
(srfi srfi-1)
(scm framework-ps)
(lily))
+
+;;(map export
+;; (append (ly:all-stencil-expressions) (ly:all-output-backend-commands)))
+
+;; huh?
+;;(write (ly:all-output-backend-commands))
+;;(write (ly:all-stencil-expressions))
+
+
;;; helper functions, not part of output interface
(define (escape-parentheses s)
(regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post))
;;;; source file of the GNU LilyPond music typesetter
;;;;
;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
;; (debug-enable 'backtrace)
-;; the public interface is tight.
+;; The public interface is tight.
;; It has to be, because user-code is evalled with this module.
+;; ***It should also be clean, well defined, documented and reviewed***
+
+;; To be reasonably safe, you probably do not want to use the TeX
+;; backend anyway, but rather the PostScript backend. You may want
+;; to run gs in a uml sandbox too.
+
+
(define-module (scm output-tex)
#:re-export (quote)
#:export (unknown
+;;;; safe-lily.scm --
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
(define safe-objects
-
(map
(lambda (sym)
- (cons sym (primitive-eval sym)))
+ (cons sym (primitive-eval sym)))
'(ly:add-interface
ly:add-moment
ly:all-grob-interfaces
+ ly:all-output-backend-commands
+ ly:all-stencil-expressions
ly:bracket
ly:context-find
ly:context-id
ly:warn
;; need these for parsing init files:
- ;; todo: should have a macro define-safe-public
- DOUBLE-FLAT
- THREE-Q-FLAT
- FLAT
- SEMI-FLAT
- NATURAL
- SEMI-SHARP
- SHARP
+ ;; todo: should have a macro define-safe-public
+ DOUBLE-FLAT
+ THREE-Q-FLAT
+ FLAT
+ SEMI-FLAT
+ NATURAL
+ SEMI-SHARP
+ SHARP
THREE-Q-SHARP
DOUBLE-SHARP
SEMI-TONE
Vaticana_ligature::brew_ligature_primitive
Vaticana_ligature::print
Volta_bracket_interface::print
-
-
-
-
)))
(define-public (make-safe-lilypond-module)
- (let*
- ((m (make-safe-module)))
- (for-each
- (lambda (p) (module-define! m (car p) (cdr p)))
- safe-objects)
+ (let* ((m (make-safe-module)))
+ (for-each (lambda (p) (module-define! m (car p) (cdr p))) safe-objects)
m))
-
projects / lilypond.git / commitdiff