2 ;;;; beam.scm -- Beam scheme stuff
4 ;;;; source file of the GNU LilyPond music typesetter
6 ;;;; (c) 2000--2004 Jan Nieuwenhuizen <janneke@gnu.org>
10 ;; width in staff space.
12 (define (beam-flag-width-function type)
15 ((eq? type 1) 1.65) ;; FIXME: check what this should be and why
18 ;; There are several ways to calculate the direction of a beam
20 ;; * majority: number count of up or down notes
21 ;; * mean : mean centre distance of all notes
22 ;; * median : mean centre distance weighted per note
24 ;; [Ross] states that the majority of the notes dictates the
25 ;; direction (and not the mean of "center distance")
27 ;; But is that because it really looks better, or because he wants
28 ;; to provide some real simple hands-on rules?
30 ;; We have our doubts, so we simply provide all sensible alternatives.
35 ; DOCME: what goes into this func, what comes out.
37 (define (dir-compare up down)
40 ;; arguments are in the form (up . down)
41 (define-public (beam-dir-majority count total)
42 (dir-compare (car count) (cdr count)))
44 (define-public (beam-dir-majority-median count total)
45 "First try majority. If that doesn't work, try median."
46 (let ((maj (dir-compare (car count) (cdr count))))
49 (beam-dir-median count total))
53 (define-public (beam-dir-mean count total)
54 (dir-compare (car total) (cdr total)))
56 (define-public (beam-dir-median count total)
57 (if (and (> (car count) 0)
59 (dir-compare (/ (car total) (car count)) (/ (cdr total) (cdr count)))
60 (dir-compare (car count) (cdr count))))
63 (define ((check-beam-quant posl posr) beam)
64 "Check whether BEAM has POSL and POSR quants. POSL are (POSITION
65 . QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter)
69 ((posns (ly:grob-property beam 'positions))
70 (thick (ly:grob-property beam 'thickness))
71 (paper (ly:grob-paper beam))
72 (lthick (ly:output-def-lookup paper 'linethickness))
73 (staff-thick lthick) ; fixme.
74 (quant->coord (lambda (p q)
77 (+ p (- (* 0.5 q thick) (* 0.5 q lthick))))))
78 (want-l (quant->coord (car posl) (cdr posl)))
79 (want-r (quant->coord (car posr) (cdr posr)))
80 (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3))))
82 (if (or (not (almost-equal want-l (car posns)))
83 (not (almost-equal want-r (cdr posns))))
86 (format "Error in beam quanting found. Want (~S,~S) found (~S)."
89 (set! (ly:grob-property beam 'quant-score)
90 (format "(~S,~S)" want-l want-r)))
91 (set! (ly:grob-property beam 'quant-score) "")
95 (define ((check-beam-slope-sign comparison) beam)
96 "Check whether the slope of BEAM is correct wrt. COMPARISON."
98 ((posns (ly:grob-property beam 'positions))
99 (slope-sign (- (cdr posns) (car posns)))
100 (correct (comparison slope-sign 0)))
106 (format "Error in beam quanting found. Want ~S 0 found ~S."
107 (procedure-name comparison) slope-sign
109 (set! (ly:grob-property beam 'quant-score)
110 (format "~S 0" (procedure-name comparison) )))
111 (set! (ly:grob-property beam 'quant-score) "")
116 (define-public (check-quant-callbacks l r)
117 (list Beam::least_squares
120 Beam::shift_region_to_valid
122 (check-beam-quant l r)
126 (define-public (check-slope-callbacks comparison)
127 (list Beam::least_squares
130 Beam::shift_region_to_valid
132 (check-beam-slope-sign comparison)