;;; 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)
;;;
(else ;; a scheme argument
(format #f "#~a" (scheme-expr->lily-string arg)))))
(define (markup->lily-string-aux expr)
- (let ((cmd (car expr))
- (args (cdr expr)))
- (if (eqv? cmd simple-markup) ;; a simple string
- (format #f "~s" (car args))
- (format #f "\\~a~{ ~a~}"
- (proc->command cmd)
- (map-in-order arg->string args)))))
+ (if (string? expr)
+ (format #f "~s" expr)
+ (let ((cmd (car expr))
+ (args (cdr expr)))
+ (if (eqv? cmd simple-markup) ;; a simple markup
+ (format #f "~s" (car args))
+ (format #f "\\~a~{ ~a~}"
+ (proc->command cmd)
+ (map-in-order arg->string args))))))
(cond ((string? markup-expr)
(format #f "~s" markup-expr))
((eqv? (car markup-expr) simple-markup)
(else
(format #f "\\markup ~a"
(markup->lily-string-aux markup-expr)))))
+
;;;
;;; 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)
(format #f "\\key ~a \\~a~a"
(note-name->lily-string (ly:music-property key 'tonic))
(any (lambda (mode)
- (if (equal? (ly:parser-lookup (*parser*) mode) c-pitch-alist)
+ (if (and (*parser*)
+ (equal? (ly:parser-lookup (*parser*) mode) c-pitch-alist))
(symbol->string mode)
#f))
'(major minor ionian locrian aeolian mixolydian lydian phrygian dorian))
"\\\\")
(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?
-
(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))
+ (ctx (ly:music-property applyoutput 'context-type)))
+ (format #f "\\applyOutput #'~a #~a"
+ ctx
(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)
(ly:music-property expr 'quoted-music-name)
(music->lily-string (ly:music-property expr 'element)))))
+;;;
+;;; Breaks
+;;;
+(define-display-method LineBreakEvent (expr)
+ (if (null? (ly:music-property expr 'break-permission))
+ "\\noBreak"
+ "\\break"))
+
+(define-display-method PageBreakEvent (expr)
+ (if (null? (ly:music-property expr 'break-permission))
+ "\\noPageBreak"
+ "\\pageBreak"))
+
+(define-display-method PageTurnEvent (expr)
+ (if (null? (ly:music-property expr 'break-permission))
+ "\\noPageTurn"
+ "\\pageTurn"))
+
+(define-extra-display-method EventChord (expr)
+ (with-music-match (expr (music 'EventChord
+ elements ((music 'LineBreakEvent
+ break-permission 'force)
+ (music 'PageBreakEvent
+ break-permission 'force))))
+ "\\pageBreak"))
+
+(define-extra-display-method EventChord (expr)
+ (with-music-match (expr (music 'EventChord
+ elements ((music 'LineBreakEvent
+ break-permission 'force)
+ (music 'PageBreakEvent
+ break-permission 'force)
+ (music 'PageTurnEvent
+ break-permission 'force))))
+ "\\pageTurn"))
+
;;;
;;; Lyrics
;;;
(parameterize ((*explicit-mode* #f))
(music->lily-string (ly:music-property expr 'element)))))
-(define-display-method OldLyricCombineMusic (expr)
- (format #f "\\oldaddlyrics ~a~a~a"
- (music->lily-string (first (ly:music-property expr 'elements)))
- (new-line->lily-string)
- (music->lily-string (second (ly:music-property expr 'elements)))))
-
;; \addlyrics
(define-extra-display-method SimultaneousMusic (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)))))
projects / lilypond.git / blobdiff