;;; define-music-display-methods.scm -- data for displaying music
;;; expressions using LilyPond notation.
;;;
-;;; (c) 2005 Nicolas Sceaux <nicolas.sceaux@free.fr>
+;;; (c) 2005--2006 Nicolas Sceaux <nicolas.sceaux@free.fr>
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (scm display-lily))
-
;;; `display-lily-init' must be called before using `display-lily-music'. It
;;; takes a parser object as an argument.
(define-public (display-lily-init parser)
(*parser* parser)
- (set-note-names! (ly:parser-lookup (*parser*) 'pitchnames))
#t)
;;;
;;;
;;; pitch names
;;;
-(define note-names '())
-(define (set-note-names! pitchnames)
- (set! note-names (map-in-order (lambda (name+lypitch)
- (cons (cdr name+lypitch) (car name+lypitch)))
- pitchnames)))
+;; It is a pity that there is no rassoc in Scheme.
+(define* (rassoc item alist #:optional (test equal?))
+ (do ((alist alist (cdr alist))
+ (result #f result))
+ ((or result (null? alist)) result)
+ (if (and (car alist) (test item (cdar alist)))
+ (set! result (car alist)))))
(define (note-name->lily-string ly-pitch)
;; here we define a custom pitch= function, since we do not want to
(define (pitch= pitch1 pitch2)
(and (= (ly:pitch-notename pitch1) (ly:pitch-notename pitch2))
(= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2))))
- (let ((result (assoc ly-pitch note-names pitch=))) ;; assoc from srfi-1
+ (let ((result (rassoc ly-pitch (ly:parser-lookup (*parser*) 'pitchnames) pitch=)))
(if result
- (cdr result)
+ (car result)
#f)))
(define (octave->lily-string pitch)
(define* (event-direction->lily-string event #:optional (required #t))
(let ((direction (ly:music-property event 'direction)))
- (cond ((or (not direction) (null? direction) (= 0 direction))
+ (cond ((or (not direction) (null? direction) (= CENTER direction))
(if required "-" ""))
- ((= 1 direction) "^")
- ((= -1 direction) "_")
+ ((= UP direction) "^")
+ ((= DOWN direction) "_")
(else ""))))
(define-macro (define-post-event-display-method type vars direction-required str)
`(define-display-method ,type ,vars
(format #f "~a~a"
(event-direction->lily-string ,(car vars) ,direction-required)
- (if (= -1 (ly:music-property ,(car vars) 'span-direction))
+ (if (= START (ly:music-property ,(car vars) 'span-direction))
,str-start
,str-stop))))
duration (ly:make-duration 0 0 0 1))
(music
'SlurEvent
- span-direction -1))))))
+ span-direction START))))))
#t)
(with-music-match (?stop (music
'SequentialMusic
duration (ly:make-duration 0 0 0 1))
(music
'SlurEvent
- span-direction 1))))))
+ span-direction STOP))))))
(format #f "\\appoggiatura ~a" (music->lily-string ?music))))))
duration (ly:make-duration 0 0 0 1))
(music
'SlurEvent
- span-direction -1)))
+ span-direction START)))
(music
'ContextSpeccedMusic
element (music
'OverrideProperty
- grob-property 'stroke-style
+ grob-property-path '(stroke-style)
grob-value "grace"
symbol 'Stem)))))
#t)
'ContextSpeccedMusic
element (music
'RevertProperty
- grob-property 'stroke-style
+ grob-property-path '(stroke-style)
symbol 'Stem))
(music
'EventChord
duration (ly:make-duration 0 0 0 1))
(music
'SlurEvent
- span-direction 1))))))
+ span-direction STOP))))))
(format #f "\\acciaccatura ~a" (music->lily-string ?music))))))
(define-extra-display-method GraceMusic (expr)
"\\\\")
(define-display-method LigatureEvent (ligature)
- (if (= -1 (ly:music-property ligature 'span-direction))
+ (if (= START (ly:music-property ligature 'span-direction))
"\\["
"\\]"))
(define-display-method BarCheck (check)
(format #f "|~a" (new-line->lily-string)))
-(define-display-method BreakEvent (br)
- "\\break") ;; TODO: use page-penalty, penalty properties?
+;; TODO: also display something when there is a penalty?
+(define-display-method LineBreakEvent (br)
+ (if (eq? (ly:music-property br 'break-permission) 'forbid)
+ ("\\noBreak")
+ ("\\break")))
+
+(define-display-method PageBreakEvent (br)
+ (if (eq? (ly:music-property br 'break-permission) 'forbid)
+ ("\\noPageBreak")
+ ("\\pageBreak")))
+
+(define-display-method PageTurnEvent (br)
+ (if (eq? (ly:music-property br 'break-permission) 'forbid)
+ ("\\noPageTurn")
+ ("\\pageTurn")))
(define-display-method PesOrFlexaEvent (expr)
"\\~")
(bracket-stop (ly:music-property figure 'bracket-stop)))
(format #f "~a~a~a~a"
(if (null? bracket-start) "" "[")
- (if (null? fig)
- "_"
- (second fig)) ;; fig: (<number-markup> "number")
+ (cond ((null? fig) "_")
+ ((markup? fig) (second fig)) ;; fig: (<number-markup> "number")
+ (else fig))
(if (null? alteration)
""
(case alteration
(define-display-method ContextSpeccedMusic (expr)
(let ((id (ly:music-property expr 'context-id))
+ (create-new (ly:music-property expr 'create-new))
(music (ly:music-property expr 'element))
(operations (ly:music-property expr 'property-operations))
(ctype (ly:music-property expr 'context-type)))
(format #f "~a ~a~a~a ~a"
- (if (and (not (null? id))
- (equal? id "$uniqueContextId"))
+ (if (and (not (null? create-new)) create-new)
"\\new"
"\\context")
ctype
- (if (or (null? id)
- (equal? id "$uniqueContextId"))
+ (if (null? id)
""
(format #f " = ~s" id))
(if (null? operations)
;; special cases: \figures \lyrics \drums
(define-extra-display-method ContextSpeccedMusic (expr)
(with-music-match (expr (music 'ContextSpeccedMusic
- context-id "$uniqueContextId"
+ create-new #t
property-operations ?op
context-type ?context-type
element ?sequence))
(define-display-method OverrideProperty (expr)
(let ((symbol (ly:music-property expr 'symbol))
- (property (ly:music-property expr 'grob-property))
+ (properties (ly:music-property expr 'grob-property-path))
(value (ly:music-property expr 'grob-value))
(once (ly:music-property expr 'once)))
(format #f "~a\\override ~a~a #'~a = ~a~a"
""
(format #f "~a . " (*current-context*)))
symbol
- property
+ (if (null? (cdr properties))
+ (car properties)
+ properties)
(property-value->lily-string value)
(new-line->lily-string))))
(define-display-method RevertProperty (expr)
(let ((symbol (ly:music-property expr 'symbol))
- (property (ly:music-property expr 'grob-property)))
+ (properties (ly:music-property expr 'grob-property-path)))
(format #f "\\revert ~a~a #'~a~a"
(if (eqv? (*current-context*) 'Bottom)
""
(format #f "~a . " (*current-context*)))
symbol
- property
+ (if (null? (cdr properties))
+ (car properties)
+ properties)
(new-line->lily-string))))
;;; \clef
(define-extra-display-method ContextSpeccedMusic (expr)
"If `expr' is a bar, return \"\\bar ...\".
Otherwise, return #f."
- (with-music-match (expr (music
- 'ContextSpeccedMusic
- element (music
- 'ContextSpeccedMusic
- context-type 'Timing
- element (music
- 'PropertySet
- value ?bar-type
- symbol 'whichBar))))
+ (with-music-match (expr (music 'ContextSpeccedMusic
+ context-type 'Timing
+ element (music 'PropertySet
+ value ?bar-type
+ symbol 'whichBar)))
(format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
;;; \partial
;;;
(define-display-method ApplyOutputEvent (applyoutput)
- (let ((proc (ly:music-property applyoutput 'procedure))))
- (format #f "\\applyoutput #~a"
+ (let ((proc (ly:music-property applyoutput 'procedure)))
+ (format #f "\\applyOutput #~a"
(or (procedure-name proc)
(with-output-to-string
(lambda ()
- (pretty-print (procedure-source proc)))))))
+ (pretty-print (procedure-source proc))))))))
(define-display-method ApplyContext (applycontext)
- (let ((proc (ly:music-property applycontext 'procedure))))
- (format #f "\\applycontext #~a"
+ (let ((proc (ly:music-property applycontext 'procedure)))
+ (format #f "\\applyContext #~a"
(or (procedure-name proc)
(with-output-to-string
(lambda ()
- (pretty-print (procedure-source proc)))))))
+ (pretty-print (procedure-source proc))))))))
;;; \partcombine
(define-display-method PartCombineMusic (expr)
(with-music-match (expr (music 'SimultaneousMusic
elements ((music 'ContextSpeccedMusic
context-id ?id
- ;;property-operations '()
context-type 'Voice
element ?note-sequence)
(music 'ContextSpeccedMusic
- context-id "$uniqueContextId"
- ;;property-operations '()
context-type 'Lyrics
+ create-new #t
element (music 'LyricCombineMusic
associated-context ?associated-id
element ?lyric-sequence)))))