X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fbeam.scm;h=0ac7f7f81f105265393acf90c22fc34466e2582b;hb=a394b88b1955d2dc6aabd61ac6115a79808cf2e7;hp=ac9c1ffc80e53ba5ca7ffa2e9b5fac29ae108f58;hpb=fdb66b65c89bf9e98da8975999815228d5f0449e;p=lilypond.git diff --git a/scm/beam.scm b/scm/beam.scm index ac9c1ffc80..0ac7f7f81f 100644 --- a/scm/beam.scm +++ b/scm/beam.scm @@ -1,148 +1,132 @@ +;;;; +;;;; beam.scm -- Beam scheme stuff +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2000--2004 Jan Nieuwenhuizen +;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; BEAMS -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (default-beam-space-function multiplicity) - (if (<= multiplicity 3) 0.816 0.844) - ) - -; -; width in staff space. -; -(define (default-beam-flag-width-function type) +;; +;; width in staff space. +;; +(define (beam-flag-width-function type) (cond ((eq? type 1) 1.98) ((eq? type 1) 1.65) ;; FIXME: check what this should be and why - (else 1.32) - )) - - -; This is a mess : global namespace pollution. We should wait -; till guile has proper toplevel environment support. - - -;; Beams should be prevented to conflict with the stafflines, -;; especially at small slopes -;; ---------------------------------------------------------- -;; ######## -;; ######## -;; ######## -;; --------------########------------------------------------ -;; ######## -;; -;; hang straddle sit inter hang - -;; inter seems to be a modern quirk, we don't use that - - -;; Note: quanting period is take as quants.top () - quants[0], -;; which should be 1 (== 1 interline) -(define (mean a b) (* 0.5 (+ a b))) -(define (default-beam-dy-quants beam stafflinethick) - (let ((thick (ly-get-elt-property beam 'thickness)) - ) - - (list 0 (mean thick stafflinethick) (+ thick stafflinethick) 1) - )) - -;; two popular veritcal beam quantings -;; see params.ly: #'beam-vertical-quants - -; (todo: merge these 2 funcs ? ) - -(define (default-beam-y-quants beam multiplicity dy staff-line) - (let* ((beam-straddle 0) - (thick (ly-get-elt-property beam 'thickness)) - (beam-sit (/ (+ thick staff-line) 2)) - (beam-hang (- 1 (/ (- thick staff-line) 2))) - (quants (list beam-hang)) - ) - - (if (or (<= multiplicity 1) (>= (abs dy) (/ staff-line 2))) - (set! quants (cons beam-sit quants))) - (if (or (<= multiplicity 2) (>= (abs dy) (/ staff-line 2))) - (set! quants (cons beam-straddle quants))) - ;; period: 1 (interline) - (append quants (list (+ 1 (car quants)))))) - -(define (beam-traditional-y-quants beam multiplicity dy staff-line) - (let* ((beam-straddle 0) - (thick (ly-get-elt-property beam 'thickness)) - (beam-sit (/ (+ thick staff-line) 2)) - (beam-hang (- 1 (/ (- thick staff-line) 2))) - (quants '()) - ) - (if (>= dy (/ staff-line -2)) - (set! quants (cons beam-hang quants))) - (if (and (<= multiplicity 1) (<= dy (/ staff-line 2))) - (set! quants (cons beam-sit quants))) - (if (or (<= multiplicity 2) (>= (abs dy) (/ staff-line 2))) - (set! quants (cons beam-straddle quants))) - ;; period: 1 (interline) - (append quants (list (+ 1 (car quants)))))) - + (else 1.32))) ;; There are several ways to calculate the direction of a beam ;; ;; * majority: number count of up or down notes ;; * mean : mean centre distance of all notes ;; * median : mean centre distance weighted per note +;; +;; [Ross] states that the majority of the notes dictates the +;; direction (and not the mean of "center distance") +;; +;; But is that because it really looks better, or because he wants +;; to provide some real simple hands-on rules? +;; +;; We have our doubts, so we simply provide all sensible alternatives. + + +;; +; +; DOCME: what goes into this func, what comes out. (define (dir-compare up down) (sign (- up down))) ;; arguments are in the form (up . down) -(define (beam-dir-majority count total) +(define-public (beam-dir-majority count total) (dir-compare (car count) (cdr count))) -(define (beam-dir-mean count total) +(define-public (beam-dir-majority-median count total) + "First try majority. If that doesn't work, try median." + (let ((maj (dir-compare (car count) (cdr count)))) + (if (not (= maj 0)) + maj + (beam-dir-median count total)) + )) + + +(define-public (beam-dir-mean count total) (dir-compare (car total) (cdr total))) -(define (beam-dir-median count total) +(define-public (beam-dir-median count total) (if (and (> (car count) 0) (> (cdr count) 0)) (dir-compare (/ (car total) (car count)) (/ (cdr total) (cdr count))) (dir-compare (car count) (cdr count)))) +(define ((check-beam-quant posl posr) beam) + "Check whether BEAM has POSL and POSR quants. POSL are (POSITION +. QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter) + +" + (let* + ((posns (ly:grob-property beam 'positions)) + (thick (ly:grob-property beam 'thickness)) + (paper (ly:grob-paper beam)) + (lthick (ly:output-def-lookup paper 'linethickness)) + (staff-thick lthick) ; fixme. + (quant->coord (lambda (p q) + (if (= 2 (abs q)) + (+ p (/ q 4.0)) + (+ p (- (* 0.5 q thick) (* 0.5 q lthick)))))) + (want-l (quant->coord (car posl) (cdr posl))) + (want-r (quant->coord (car posr) (cdr posr))) + (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3)))) + + (if (or (not (almost-equal want-l (car posns))) + (not (almost-equal want-r (cdr posns)))) + (begin + (ly:warn + "Error in beam quanting found. Want (~S,~S) found (~S)." + want-l want-r posns ) + (set! (ly:grob-property beam 'quant-score) + (format "(~S,~S)" want-l want-r))) + (set! (ly:grob-property beam 'quant-score) "") + + + ))) +(define ((check-beam-slope-sign comparison) beam) + "Check whether the slope of BEAM is correct wrt. COMPARISON." + (let* + ((posns (ly:grob-property beam 'positions)) + (slope-sign (- (cdr posns) (car posns))) + (correct (comparison slope-sign 0))) -;; [Ross] states that the majority of the notes dictates the -;; direction (and not the mean of "center distance") -;; -;; But is that because it really looks better, or because he wants -;; to provide some real simple hands-on rules? -;; -;; We have our doubts, so we simply provide all sensible alternatives. - -;; array index multiplicity, last if index>size -;; beamed stems - - -;; TODO -;; - take #forced stems into account (now done in C++)? -;; - take y-position of chord or beam into account + + (if (not correct) + (begin + (ly:warn "Error in beam quanting found. Want ~S 0 found ~S." + (procedure-name comparison) slope-sign) + (set! (ly:grob-property beam 'quant-score) + (format "~S 0" (procedure-name comparison) ))) + (set! (ly:grob-property beam 'quant-score) "") + + + ))) + +(define-public (check-quant-callbacks l r) + (list Beam::least_squares + Beam::check_concave + Beam::slope_damping + Beam::shift_region_to_valid + Beam::quanting + (check-beam-quant l r) + )) -; -; todo: clean this up a bit: the list is getting rather long. -; -(define basic-beam-properties - `( - (molecule-callback . ,Beam::brew_molecule) - (thickness . 0.42) ; in staff-space, should use stafflinethick? - (before-line-breaking-callback . ,Beam::before_line_breaking) - (after-line-breaking-callback . ,Beam::after_line_breaking) - (default-neutral-direction . 1) - (dir-function . ,beam-dir-majority) - (height-quants . ,default-beam-dy-quants) - (vertical-position-quant-function . ,default-beam-y-quants) - (beamed-stem-shorten . (0.5)) - (outer-stem-length-limit . 0.2) - (slope-limit . 0.2) - (flag-width-function . ,default-beam-flag-width-function) - (space-function . ,default-beam-space-function) - (damping . 1) - (meta . ,(element-description "Beam" beam-interface)) - ) - ) + +(define-public (check-slope-callbacks comparison) + (list Beam::least_squares + Beam::check_concave + Beam::slope_damping + Beam::shift_region_to_valid + Beam::quanting + (check-beam-slope-sign comparison) + )) +