scm/beam.scm

   1 ;;;;
   2 ;;;; beam.scm -- Beam scheme stuff
   3 ;;;;
   4 ;;;; source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c) 2000--2005 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;;
   8
   9 ;;
  10 ;; width in staff space.
  11 ;;
  12 (define (beam-flag-width-function type)
  13   (cond
  14    ((eq? type 1) 1.98)
  15    ((eq? type 1) 1.65) ;; FIXME: check what this should be and why
  16    (else 1.32)))
  17
  18 ;; There are several ways to calculate the direction of a beam
  19 ;;
  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
  23 ;;
  24 ;; [Ross] states that the majority of the notes dictates the
  25 ;; direction (and not the mean of "center distance")
  26 ;;
  27 ;; But is that because it really looks better, or because he wants
  28 ;; to provide some real simple hands-on rules?
  29 ;;
  30 ;; We have our doubts, so we simply provide all sensible alternatives.
  31
  32
  33 ;;
  34 ;; DOCME: what goes into this func, what comes out.
  35 (define (dir-compare up down)
  36   (sign (- up down)))
  37
  38 ;; arguments are in the form (up . down)
  39 (define-public (beam-dir-majority count total)
  40   (dir-compare (car count) (cdr count)))
  41
  42 (define-public (beam-dir-majority-median count total)
  43   "First try majority. If that doesn't work, try median."
  44   (let ((maj (dir-compare (car count) (cdr count))))
  45     (if (not (= maj 0))
  46         maj
  47         (beam-dir-median count total))))
  48
  49 (define-public (beam-dir-mean count total)
  50   (dir-compare (car total) (cdr total)))
  51
  52 (define-public (beam-dir-median count total)
  53   (if (and (> (car count) 0)
  54            (> (cdr count) 0))
  55       (dir-compare (/ (car total) (car count)) (/ (cdr total) (cdr count)))
  56       (dir-compare (car count) (cdr count))))
  57
  58 (define ((check-beam-quant posl posr) beam)
  59   "Check whether BEAM has POSL and POSR quants.  POSL are (POSITION
  60 . QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter)
  61
  62 "
  63   (let* ((posns (ly:grob-property beam 'positions))
  64          (thick (ly:grob-property beam 'thickness))
  65          (layout (ly:grob-layout beam))
  66          (lthick (ly:output-def-lookup layout 'linethickness))
  67          (staff-thick lthick) ; fixme.
  68          (quant->coord (lambda (p q)
  69                          (if (= 2 (abs q))
  70                              (+ p (/ q 4.0))
  71                              (+ p (- (* 0.5 q thick) (* 0.5 q lthick))))))
  72          (want-l (quant->coord (car posl) (cdr posl)))
  73          (want-r (quant->coord (car posr) (cdr posr)))
  74          (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3))))
  75
  76     (if (or (not (almost-equal want-l (car posns)))
  77             (not (almost-equal want-r (cdr posns))))
  78         (begin
  79           (ly:warn
  80            "Error in beam quanting found. Want (~S,~S) found (~S)."
  81            want-l want-r posns )
  82           (set! (ly:grob-property beam 'quant-score)
  83                 (format "(~S,~S)" want-l want-r)))
  84         (set! (ly:grob-property beam 'quant-score) ""))))
  85 (define ((check-beam-slope-sign comparison) beam)
  86   "Check whether the slope of BEAM is correct wrt. COMPARISON."
  87   (let* ((posns (ly:grob-property beam 'positions))
  88          (slope-sign (- (cdr posns) (car posns)))
  89          (correct (comparison slope-sign 0)))
  90
  91
  92     (if (not correct)
  93         (begin
  94           (ly:warn "Error in beam quanting found. Want ~S 0 found ~S."
  95                    (procedure-name comparison) slope-sign)
  96           (set! (ly:grob-property beam 'quant-score)
  97                 (format "~S 0" (procedure-name comparison))))
  98         (set! (ly:grob-property beam 'quant-score) ""))))
  99
 100 (define-public (check-quant-callbacks l r)
 101   (list Beam::least_squares
 102         Beam::check_concave
 103         Beam::slope_damping
 104         Beam::shift_region_to_valid
 105         Beam::quanting
 106         (check-beam-quant l r)))
 107
 108
 109 (define-public (check-slope-callbacks comparison)
 110   (list Beam::least_squares
 111         Beam::check_concave
 112         Beam::slope_damping
 113         Beam::shift_region_to_valid
 114         Beam::quanting
 115         (check-beam-slope-sign comparison)))
 116