1 ;;; display-lily.scm -- Display music expressions using LilyPond notation
5 ;;; (c) 2005 Nicolas Sceaux <nicolas.sceaux@free.fr>
8 ;;; - This file defines the procedures used to define display methods for each
9 ;;; music type: define-display-method and define-extra-display-method.
10 ;;; See scm/define-music-display-methods.scm
11 ;;; Display methods are stored in the `display-methods' property of each music
14 ;;; - `display-lily-music' can be called to display a music expression using
15 ;;; LilyPond notation. `music->lily-string' return a string describing a music
16 ;;; expression using LilyPond notation.
18 ;;; - `with-music-match' can be used to destructure a music expression, extracting
19 ;;; some interesting music properties.
22 (define-module (scm display-lily)
23 #:use-module (ice-9 optargs)
24 #:use-module (ice-9 format)
25 #:use-module (ice-9 regex)
26 #:use-module (ice-9 pretty-print)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-13)
29 #:use-module (srfi srfi-39)
31 #:use-syntax (srfi srfi-39)
32 #:use-syntax (ice-9 optargs))
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;;; Display method definition and call
40 (define-macro (define-display-method music-type vars . body)
41 "Define a display method for a music type and store it in the
42 `display-methods' property of the music type entry found in the
43 `music-name-to-property-table' hash table. Print methods previously
44 defined for that music type are lost.
45 Syntax: (define-display-method MusicType (expression)
47 `(let ((type-props (hashq-ref music-name-to-property-table
52 (assoc-set! type-props 'display-methods (list method)))
53 (hashq-set! music-name-to-property-table
58 (define-macro (define-extra-display-method music-type vars . body)
59 "Add a display method for a music type. A primary display method
60 is supposed to have been previously defined with `define-display-method'.
61 This new method should return a string or #f. If #f is returned, the next
62 display method will be called."
63 `(let* ((type-props (hashq-ref music-name-to-property-table
65 (methods (assoc-ref type-props 'display-methods))
66 (new-method (lambda ,vars
69 (assoc-set! type-props
71 (cons new-method methods)))
72 (hashq-set! music-name-to-property-table
77 (define* (tag->lily-string expr #:optional (post-event? #f))
78 (let ((tags (ly:music-property expr 'tags)))
82 (format #f "~a\\tag #'~a " (if post-event? "-" "") (car tags)))
84 (format #f "~a\\tag #'(~a~{ ~a~}) " (if post-event? "-" "") (car tags) (cdr tags))))))
86 (define-public (music->lily-string expr)
87 "Print expr, a music expression, in LilyPond syntax"
89 (let* ((music-type (ly:music-property expr 'name))
90 (procs (assoc-ref (hashq-ref music-name-to-property-table
93 (result-string (and procs (any (lambda (proc)
98 (tag->lily-string expr (post-event? expr))
100 (format #f "%{ Print method not implemented for music type ~a %}"
102 (format #f "%{ expecting a music expression: ~a %}" expr)))
104 (define*-public (display-lily-music expr #:key force-duration)
105 (parameterize ((*indent* 0)
106 (*previous-duration* (ly:make-duration 2))
107 (*force-duration* force-duration))
108 (display (music->lily-string expr))
111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
113 ;;; Music pattern matching
117 (and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0))))
120 (and (pair? x) (eqv? (car x) 'music)))
122 (define (music-list? x)
126 (define (music-or-var-list? x)
129 (or (music? e) (var? e)))
132 (define (key-val-list->alist lst)
133 (define (key-val-list->alist-aux lst prev-result)
136 (key-val-list->alist-aux (cddr lst)
137 (cons (cons (first lst) (second lst))
139 (reverse! (key-val-list->alist-aux lst (list))))
141 (define (gen-condition expr pattern)
142 "Helper function for `with-music-match'.
143 Generate an form that checks if the properties of `expr'
144 match thoses desscribed in `pattern'."
145 (let* (;; all (property . value) found at the first depth in pattern,
146 ;; including a (name . <Musictype>) pair.
147 (pat-all-props (cons (cons 'name (second pattern))
148 (key-val-list->alist (cddr pattern))))
149 ;; all (property . value) pairs found in pattern, where value is not
150 ;; a ?var, a music expression or a music list.
151 (prop-vals (remove (lambda (kons)
152 (or (var? (cdr kons))
154 (music-or-var-list? (cdr kons))))
156 ;; list of (property . element) pairs, where element is a music expression
157 (element-list (filter (lambda (kons) (music? (cdr kons)))
159 ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
160 ;; list a music expressions
161 (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
164 ;; a form that checks that `expr' is a music expression
165 ;; before actually accessing its properties...
167 ;; a form that checks that `expr' properties have the same
168 ;; values as those given in `pattern'
169 ,@(map (lambda (prop-val)
170 (let ((prop (car prop-val))
171 (val (cdr prop-val)))
172 `(and (not (null? (ly:music-property ,expr ',prop)))
173 (equal? (ly:music-property ,expr ',prop) ,val))))
175 ;; build the test condition for each element found in a (property . element) pair.
176 ;; (typically, property will be 'element)
177 ,@(map (lambda (prop-element)
178 (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element)))
180 ;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair.
181 ;; this requires accessing to an element of a list, hence the index.
182 ;; (typically, property will be 'elements)
183 ,@(map (lambda (prop-elements)
186 `(and ,@(map (lambda (e)
187 (set! index (1+ index))
189 (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements)))
191 (list-ref (ly:music-property ,expr ',(car prop-elements))
195 (cdr prop-elements)))))
198 (define (gen-bindings expr pattern)
199 "Helper function for `with-music-match'.
200 Generate binding forms by looking for ?var symbol in pattern."
201 (let* (;; all (property . value) found at the first depth of pattern,
202 ;; including a (name . <Musictype>) pair.
203 (pat-all-props (cons (cons 'name (second pattern))
204 (key-val-list->alist (cddr pattern))))
205 ;; all (property . ?var) pairs
206 (prop-vars (filter (lambda (kons) (var? (cdr kons)))
208 ;; list of (property . element) pairs, where element is a music expression
209 (element-list (filter (lambda (kons) (music? (cdr kons)))
211 ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
212 ;; list a music expressions
213 (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
216 ;; the binding form for the ?var variable found in pattern (first depth).
217 ;; ?var is bound to the value of `expr' property
218 (map (lambda (prop-var)
219 `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var))))
221 ;; generate bindings for each element found in a (property . element) pair.
222 ;; (typically, property will be 'element)
223 (append-map (lambda (prop-element)
224 (gen-bindings `(ly:music-property ,expr ',(car prop-element))
227 ;; generate bindings for each element found in a (property . (e1 e2 ...)) pair
228 ;; (typically, property will be 'elements)
229 (append-map (lambda (prop-elements)
231 (append-map (lambda (e)
232 (set! index (1+ index))
234 `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index)))
235 (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements))
238 (cdr prop-elements))))
241 (define-macro (with-music-match music-expr+pattern . body)
242 "If `music-expr' matches `pattern', call `body'. `pattern' should look like:
246 element (music <MusicType> ...)
247 elements ((music <MusicType> ...)
249 (music <MusicType> ...)))
250 The properties of `music-expr' are checked against the values given in the
251 pattern (the name property being the <MusicType> symbol after the `music'
252 keyword), then all music expression found in its properties (such as 'element
254 When ?var is found instead of a property value, ?var is bound that property value,
255 as read inside `music-expr'. ?var may also be used to refere to a whole music
256 expression inside an elements list for instance. These bindings are accessible
258 (let ((music-expr (first music-expr+pattern))
259 (pattern (second music-expr+pattern))
261 `(let ((,expr-sym ,music-expr))
262 (if ,(gen-condition expr-sym pattern)
263 (let ,(gen-bindings expr-sym pattern)
267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
269 ;;; Special parameters
273 (define *indent* (make-parameter 0))
275 ;;; set to #t to force duration printing
276 (define *force-duration* (make-parameter #f))
278 ;;; last duration found
279 (define *previous-duration* (make-parameter (ly:make-duration 2)))
281 ;;; Set to #t to force a line break with some kinds of expressions (eg sequential music)
282 (define *force-line-break* (make-parameter #t))
283 (define *max-element-number-before-break* (make-parameter 6))
285 ;; \times factor (used in durations)
286 (define *time-factor-denominator* (make-parameter #f))
287 (define *time-factor-numerator* (make-parameter #f))
289 (define *parser* (make-parameter #f))
291 (define *current-context* (make-parameter 'Bottom))
293 (define *explicit-mode* (make-parameter #t))
295 (define (new-line->lily-string)
296 (format #f "~%~v_" (max 0 (1- (*indent*)))))
299 ;;; music type predicate maker
302 (define (make-music-type-predicate . music-types)
303 (define ((make-music-type-predicate-aux mtypes) expr)
306 (or (eqv? (car mtypes) (ly:music-property expr 'name))
307 ((make-music-type-predicate-aux (cdr mtypes)) expr))))
308 (make-music-type-predicate-aux music-types))
310 (load "define-music-display-methods.scm")