;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
(ly:text-interface::interpret-markup layout props text)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; beam slope
+;; sets position of beams for Kievan notation
+(define-public (beam::get-positions grob)
+ (let* ((stems (ly:grob-object grob 'stems))
+ (stems-grobs (if (not (null? stems))
+ (ly:grob-array->list stems)
+ '()))
+ (first-stem (if (not (null? stems-grobs))
+ (car stems-grobs)
+ '()))
+ (note-heads (if (not (null? first-stem))
+ (ly:grob-object first-stem 'note-heads)
+ '()))
+ (note-heads-grobs (if (not (null? note-heads))
+ (ly:grob-array->list note-heads)
+ '()))
+ (first-note-head (if (not (null? note-heads-grobs))
+ (car note-heads-grobs)
+ '()))
+ (style (if (not (null? first-note-head))
+ (ly:grob-property first-note-head 'style)
+ '())))
+ (if (and (symbol? style) (string-match "kievan*" (symbol->string style)))
+ (let* ((next-stem (cadr stems-grobs))
+ (next-note-heads (if (not (null? next-stem))
+ (ly:grob-object next-stem 'note-heads)
+ '()))
+ (next-note-heads-grobs (if (not (null? next-note-heads))
+ (ly:grob-array->list next-note-heads)
+ '()))
+ (next-note-head (if (not (null? next-note-heads-grobs))
+ (car next-note-heads-grobs)
+ '()))
+ (left-pos (ly:grob-property first-note-head 'Y-offset))
+ (right-pos (ly:grob-property next-note-head 'Y-offset))
+ (direction (ly:grob-property grob 'direction))
+ (left-height (if (= direction DOWN)
+ (+ (car (ly:grob::stencil-height first-note-head)) 0.75)
+ (- (cdr (ly:grob::stencil-height first-note-head)) 0.75)))
+ (right-height (if (= direction DOWN)
+ (+ (car (ly:grob::stencil-height next-note-head)) 0.75)
+ (- (cdr (ly:grob::stencil-height next-note-head)) 0.75))))
+ (cons (+ left-pos left-height) (+ right-pos right-height)))
+ (beam::place-broken-parts-individually grob))))
+
+(define-public (beam::get-quantized-positions grob)
+ (let* ((stems (ly:grob-object grob 'stems))
+ (stems-grobs (if (not (null? stems))
+ (ly:grob-array->list stems)
+ '()))
+ (first-stem (if (not (null? stems-grobs))
+ (car stems-grobs)
+ '()))
+ (note-heads (if (not (null? first-stem))
+ (ly:grob-object first-stem 'note-heads)
+ '()))
+ (note-heads-grobs (if (not (null? note-heads))
+ (ly:grob-array->list note-heads)
+ '()))
+ (first-note-head (if (not (null? note-heads-grobs))
+ (car note-heads-grobs)
+ '()))
+ (style (if (not (null? first-note-head))
+ (ly:grob-property first-note-head 'style)
+ '())))
+ (if (and (symbol? style) (string-match "kievan*" (symbol->string style)))
+ (let* ((next-stem (cadr stems-grobs))
+ (next-note-heads (if (not (null? next-stem))
+ (ly:grob-object next-stem 'note-heads)
+ '()))
+ (next-note-heads-grobs (if (not (null? next-note-heads))
+ (ly:grob-array->list next-note-heads)
+ '()))
+ (next-note-head (if (not (null? next-note-heads-grobs))
+ (car next-note-heads-grobs)
+ '()))
+ (left-pos (ly:grob-property first-note-head 'Y-offset))
+ (right-pos (ly:grob-property next-note-head 'Y-offset))
+ (direction (ly:grob-property grob 'direction))
+ (left-height (if (= direction DOWN)
+ (+ (car (ly:grob::stencil-height first-note-head)) 0.75)
+ (- (cdr (ly:grob::stencil-height first-note-head)) 0.75)))
+ (right-height (if (= direction DOWN)
+ (+ (car (ly:grob::stencil-height next-note-head)) 0.75)
+ (- (cdr (ly:grob::stencil-height next-note-head)) 0.75))))
+ (cons (+ left-pos left-height) (+ right-pos right-height)))
+ (ly:beam::set-stem-lengths grob))))
+
;; calculates each slope of a broken beam individually
(define-public (beam::place-broken-parts-individually grob)
(ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
(define-public (stem::length grob)
(let* ((ss (ly:staff-symbol-staff-space grob))
(beg (ly:grob-property grob 'stem-begin-position))
- (beam (ly:grob-object grob 'beam)))
- (if (null? beam)
- (abs (- (ly:stem::calc-stem-end-position grob) beg))
+ (beam (ly:grob-object grob 'beam))
+ (note-heads (ly:grob-object grob 'note-heads))
+ (note-heads-grobs (if (not (null? note-heads))
+ (ly:grob-array->list note-heads)
+ '()))
+ (first-note-head (if (not (null? note-heads-grobs))
+ (car note-heads-grobs)
+ '()))
+ (style (if (not (null? first-note-head))
+ (ly:grob-property first-note-head 'style)
+ '())))
+ (cond
+ ((and (symbol? style) (string-match "kievan*" (symbol->string style))) 0.0)
+ ((null? beam) (abs (- (ly:stem::calc-stem-end-position grob) beg)))
+ (else
(begin
(ly:programming-error
"stem::length called but will not be used for beamed stem.")
- 0.0))))
+ 0.0)))))
(define-public (stem::pure-length grob beg end)
(let* ((ss (ly:staff-symbol-staff-space grob))
(beg (ly:grob-pure-property grob 'stem-begin-position 0 1000)))
(abs (- (ly:stem::pure-calc-stem-end-position grob 0 2147483646) beg))))
+(define (stem-stub::do-calculations grob)
+ (and (ly:grob-property (ly:grob-parent grob X) 'cross-staff)
+ (not (ly:grob-property (ly:grob-parent grob X) 'transparent))))
+
+(define-public (stem-stub::pure-height grob beg end)
+ (if (stem-stub::do-calculations grob)
+ '(0 . 0)
+ '(+inf.0 . -inf.0)))
+
+(define-public (stem-stub::width grob)
+ (if (stem-stub::do-calculations grob)
+ (grob::x-parent-width grob)
+ '(+inf.0 . -inf.0)))
+
+(define-public (stem-stub::extra-spacing-height grob)
+ (if (stem-stub::do-calculations grob)
+ (let* ((dad (ly:grob-parent grob X))
+ (refp (ly:grob-common-refpoint grob dad Y))
+ (stem_ph (ly:grob-pure-height dad refp 0 1000000))
+ (my_ph (ly:grob-pure-height grob refp 0 1000000))
+ ;; only account for distance if stem is on different staff than stub
+ (dist (if (grob::has-interface refp 'hara-kiri-group-spanner-interface)
+ 0
+ (- (car my_ph) (car stem_ph)))))
+ (if (interval-empty? (interval-intersection stem_ph my_ph)) #f (coord-translate stem_ph dist)))
+ #f))
+
+;; FIXME: NEED TO FIND A BETTER WAY TO HANDLE KIEVAN NOTATION
(define-public (note-head::calc-duration-log grob)
- (min 2
- (ly:duration-log
- (ly:event-property (event-cause grob) 'duration))))
+ (let ((style (ly:grob-property grob 'style)))
+ (if (and (symbol? style) (string-match "kievan*" (symbol->string style)))
+ (min 3
+ (ly:duration-log
+ (ly:event-property (event-cause grob) 'duration)))
+ (min 2
+ (ly:duration-log
+ (ly:event-property (event-cause grob) 'duration))))))
(define-public (dots::calc-dot-count grob)
(ly:duration-dot-count
(string-append (number->string log) "petrucci")))
((neomensural)
(string-append (number->string log) (symbol->string style)))
+ ((kievan)
+ (string-append (number->string log) "kievan"))
(else
(if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
(symbol->string style)
(symbol->string style))))))
(define-public (note-head::calc-glyph-name grob)
- (let ((style (ly:grob-property grob 'style))
- (log (min 2 (ly:grob-property grob 'duration-log))))
-
+ (let* ((style (ly:grob-property grob 'style))
+ (log (if (string-match "kievan*" (symbol->string style))
+ (min 3 (ly:grob-property grob 'duration-log))
+ (min 2 (ly:grob-property grob 'duration-log)))))
(select-head-glyph style log)))
(define-public (note-head::brew-ez-stencil grob)
(define-public (rhythmic-location<=? a b)
(not (rhythmic-location<? b a)))
(define-public (rhythmic-location>=? a b)
- (rhythmic-location<? a b))
+ (not (rhythmic-location<? a b)))
(define-public (rhythmic-location>? a b)
(rhythmic-location<? b a))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Bar lines.
+;; neighbor-interface routines
-;;
-;; How should a bar line behave at a break?
-(define bar-glyph-alist
- '((":|:" . (":|" . "|:"))
- (":|.|:" . (":|" . "|:"))
- (":|.:" . (":|" . "|:"))
- ("||:" . ("||" . "|:"))
- ("dashed" . ("dashed" . '()))
- ("|" . ("|" . ()))
- ("||:" . ("||" . "|:"))
- ("|s" . (() . "|"))
- ("|:" . ("|" . "|:"))
- ("|." . ("|." . ()))
-
- ;; hmm... should we end with a bar line here?
- (".|" . ("|" . ".|"))
- (":|" . (":|" . ()))
- ("||" . ("||" . ()))
- (".|." . (".|." . ()))
- ("|.|" . ("|.|" . ()))
- ("" . ("" . ""))
- (":" . (":" . ""))
- ("." . ("." . ()))
- ("'" . ("'" . ()))
- ("empty" . (() . ()))
- ("brace" . (() . "brace"))
- ("bracket" . (() . "bracket"))
-
- ;; segno bar lines
- ("S" . ("||" . "S"))
- ("|S" . ("|" . "S"))
- ("S|" . ("S" . ()))
- (":|S" . (":|" . "S"))
- (":|S." . (":|S" . ()))
- ("S|:" . ("S" . "|:"))
- (".S|:" . ("|" . "S|:"))
- (":|S|:" . (":|" . "S|:"))
- (":|S.|:" . (":|S" . "|:"))))
-
-(define-public (bar-line::calc-glyph-name grob)
- (let* ((glyph (ly:grob-property grob 'glyph))
- (dir (ly:item-break-dir grob))
- (result (assoc-get glyph bar-glyph-alist))
- (glyph-name (if (= dir CENTER)
- glyph
- (if (and result
- (string? (index-cell result dir)))
- (index-cell result dir)
- #f))))
- glyph-name))
-
-(define-public (bar-line::calc-break-visibility grob)
- (let* ((glyph (ly:grob-property grob 'glyph))
- (result (assoc-get glyph bar-glyph-alist)))
-
- (if result
- (vector (string? (car result)) #t (string? (cdr result)))
- all-invisible)))
(define-public (shift-right-at-line-begin g)
"Shift an item to the right, but only at the start of the line."
(cons -0.1 0.1)))
(define-public (pure-from-neighbor-interface::extra-spacing-height grob)
- (let* ((height (ly:grob::stencil-height grob))
+ (let* ((height (ly:grob-pure-height grob grob 0 10000000))
(from-neighbors (interval-union
height
(ly:axis-group-interface::pure-height
(coord-operation - from-neighbors height)))
(define-public (pure-from-neighbor-interface::account-for-span-bar grob)
- (define (other-op x) (x (cons cdr car)))
(let* ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
- (hsb (ly:grob-property grob 'has-span-bar)))
+ (hsb (ly:grob-property grob 'has-span-bar))
+ (ii (interval-intersection esh (cons -1.01 1.01))))
(if (pair? hsb)
- (cons-map
- (lambda (x)
- (if (and ((other-op x) hsb)
- (not (and (eq? x car)
- (not (ly:grob-property grob 'allow-span-bar)))))
- (x esh)
- (x (cons -1.01 1.01))))
- (cons car cdr))
- '(-1.01 . 1.01))))
+ (cons (car (if (and (car hsb)
+ (ly:grob-property grob 'allow-span-bar))
+ esh ii))
+ (cdr (if (cdr hsb) esh ii)))
+ ii)))
(define-public (pure-from-neighbor-interface::extra-spacing-height-including-staff grob)
(let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; key signature
-(define-public (key-signature-interface::alteration-position step alter
- c0-position)
- ;; TODO: memoize - this is mostly constant.
-
- ;; fes, ges, as and bes typeset in lower octave
- (define FLAT_TOP_PITCH 2)
-
- ;; ais and bis typeset in lower octave
- (define SHARP_TOP_PITCH 4)
-
- (if (pair? step)
- (+ (cdr step) (* (car step) 7) c0-position)
- (let* ((from-bottom-pos (modulo (+ 4 49 c0-position) 7))
- (p step)
- (c0 (- from-bottom-pos 4)))
-
- (if
- (or (and (< alter 0)
- (or (> p FLAT_TOP_PITCH) (> (+ p c0) 4)) (> (+ p c0) 1))
- (and (> alter 0)
- (or (> p SHARP_TOP_PITCH) (> (+ p c0) 5)) (> (+ p c0) 2)))
-
- ;; Typeset below c_position
- (set! p (- p 7)))
-
- ;; Provide for the four cases in which there's a glitch
- ;; it's a hack, but probably not worth
- ;; the effort of finding a nicer solution.
- ;; --dl.
- (cond
- ((and (= c0 2) (= p 3) (> alter 0))
- (set! p (- p 7)))
- ((and (= c0 -3) (= p -1) (> alter 0))
- (set! p (+ p 7)))
- ((and (= c0 -4) (= p -1) (< alter 0))
- (set! p (+ p 7)))
- ((and (= c0 -2) (= p -3) (< alter 0))
- (set! p (+ p 7))))
-
- (+ c0 p))))
-
+(define-public (key-signature-interface::alteration-positions
+ entry c0-position grob)
+ (let ((step (car entry))
+ (alter (cdr entry)))
+ (if (pair? step)
+ (list (+ (cdr step) (* (car step) 7) c0-position))
+ (let* ((c-position (modulo c0-position 7))
+ (positions
+ (if (< alter 0)
+ ;; See (flat|sharp)-positions in define-grob-properties.scm
+ (ly:grob-property grob 'flat-positions '(3))
+ (ly:grob-property grob 'sharp-positions '(3))))
+ (p (list-ref positions
+ (if (< c-position (length positions))
+ c-position 0)))
+ (max-position (if (pair? p) (cdr p) p))
+ (min-position (if (pair? p) (car p) (- max-position 6)))
+ (first-position (+ (modulo (- (+ c-position step)
+ min-position)
+ 7)
+ min-position)))
+ (define (prepend x l) (if (> x max-position)
+ l
+ (prepend (+ x 7) (cons x l))))
+ (prepend first-position '())))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; annotations
(define-public (accidental-interface::calc-alteration grob)
(ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch)))
+(define-public (accidental-interface::glyph-name grob)
+ (assoc-get (ly:grob-property grob 'alteration)
+ standard-alteration-glyph-name-alist))
+
(define-public cancellation-glyph-name-alist
'((0 . "accidentals.natural")))
(0 . "accidentals.vaticana0")
(1/2 . "accidentals.mensural1")))
+(define-public alteration-kievan-glyph-name-alist
+ '((-1/2 . "accidentals.kievanM1")
+ (1/2 . "accidentals.kievan1")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; * Pitch Trill Heads
(let* ((event (event-cause grob))
(digit (ly:event-property event 'digit)))
- (if (> digit 5)
- (ly:input-message (ly:event-property event 'origin)
- "Warning: Fingering notation for finger number ~a"
- digit))
-
(number->string digit 10)))
(define-public (string-number::calc-text grob)
;; dynamics
(define-public (hairpin::calc-grow-direction grob)
- (if (eq? (ly:event-property (event-cause grob) 'class) 'decrescendo-event)
+ (if (ly:in-event-class? (event-cause grob) 'decrescendo-event)
START
STOP))
projects / lilypond.git / blobdiff