scm/display-lily.scm

   1 ;;; display-lily.scm -- Display music expressions using LilyPond notation
   2 ;;;
   3 ;;;
   4 ;;;
   5 ;;; (c) 2005 Nicolas Sceaux  <nicolas.sceaux@free.fr>
   6 ;;;
   7
   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
  12 ;;; type.
  13 ;;;
  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.
  17 ;;;
  18 ;;; - `with-music-match' can be used to destructure a music expression, extracting
  19 ;;; some interesting music properties.
  20
  21
  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)
  30   #:use-module (lily)
  31   #:use-syntax (srfi srfi-39)
  32   #:use-syntax (ice-9 optargs))
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;;;
  36 ;;; Display method definition and call
  37 ;;;
  38
  39
  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)
  46           ...body...))"
  47   `(let ((type-props (hashq-ref music-name-to-property-table
  48                                 ',music-type '()))
  49          (method (lambda ,vars
  50                    ,@body)))
  51      (set! type-props
  52            (assoc-set! type-props 'display-methods (list method)))
  53      (hashq-set! music-name-to-property-table
  54                  ',music-type
  55                  type-props)
  56      method))
  57
  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
  64                                  ',music-type '()))
  65           (methods (assoc-ref type-props 'display-methods))
  66           (new-method (lambda ,vars
  67                         ,@body)))
  68      (set! type-props
  69            (assoc-set! type-props
  70                        'display-methods
  71                        (cons new-method methods)))
  72      (hashq-set! music-name-to-property-table
  73                  ',music-type
  74                  type-props)
  75      new-method))
  76
  77 (define* (tag->lily-string expr #:optional (post-event? #f))
  78   (let ((tags (ly:music-property expr 'tags)))
  79     (cond ((null? tags)
  80            "")
  81           ((null? (cdr tags))
  82            (format #f "~a\\tag #'~a " (if post-event? "-" "") (car tags)))
  83           (else
  84            (format #f "~a\\tag #'(~a~{ ~a~}) " (if post-event? "-" "") (car tags) (cdr tags))))))
  85
  86 (define-public (music->lily-string expr)
  87   "Print expr, a music expression, in LilyPond syntax"
  88   (if (ly:music? expr)
  89       (let* ((music-type (ly:music-property expr 'name))
  90              (procs (assoc-ref (hashq-ref music-name-to-property-table
  91                                           music-type '())
  92                                'display-methods))
  93              (result-string (and procs (any (lambda (proc)
  94                                               (proc expr))
  95                                             procs))))
  96         (if result-string
  97             (format #f "~a~a"
  98                     (tag->lily-string expr (post-event? expr))
  99                     result-string)
 100             (format #f "%{ Print method not implemented for music type ~a %}"
 101                     music-type)))
 102       (format #f "%{ expecting a music expression: ~a %}" expr)))
 103
 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))
 109     (newline)))
 110
 111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 112 ;;;
 113 ;;; Music pattern matching
 114 ;;;
 115
 116 (define (var? x)
 117   (and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0))))
 118
 119 (define (music? x)
 120   (and (pair? x) (eqv? (car x) 'music)))
 121
 122 (define (music-list? x)
 123   (and (pair? x)
 124        (every music? x)))
 125
 126 (define (music-or-var-list? x)
 127   (and (pair? x)
 128        (every (lambda (e)
 129                 (or (music? e) (var? e)))
 130               x)))
 131
 132 (define (key-val-list->alist lst)
 133   (define (key-val-list->alist-aux lst prev-result)
 134     (if (null? lst)
 135         prev-result
 136         (key-val-list->alist-aux (cddr lst)
 137                                  (cons (cons (first lst) (second lst))
 138                                        prev-result))))
 139   (reverse! (key-val-list->alist-aux lst (list))))
 140
 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))
 153                                  (music? (cdr kons))
 154                                  (music-or-var-list? (cdr kons))))
 155                             pat-all-props))
 156          ;; list of (property . element) pairs, where element is a music expression
 157          (element-list (filter (lambda (kons) (music? (cdr kons)))
 158                                pat-all-props))
 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)))
 162                                 pat-all-props)))
 163     `(and
 164       ;; a form that checks that `expr' is a music expression
 165       ;; before actually accessing its properties...
 166       (ly:music? ,expr)
 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))))
 174              prop-vals)
 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)))
 179              element-list)
 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)
 184                (let ((ges (gensym))
 185                      (index -1))
 186                  `(and ,@(map (lambda (e)
 187                                 (set! index (1+ index))
 188                                 (if (music? e)
 189                                     (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements)))
 190                                                             ,index)
 191                                                          (list-ref (ly:music-property ,expr ',(car prop-elements))
 192                                                                    ,index))
 193                                                    e)
 194                                     #t))
 195                               (cdr prop-elements)))))
 196              elements-list))))
 197
 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)))
 207                             pat-all-props))
 208          ;; list of (property . element) pairs, where element is a music expression
 209          (element-list (filter (lambda (kons) (music? (cdr kons)))
 210                                pat-all-props))
 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)))
 214                                 pat-all-props)))
 215     (append
 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))))
 220           prop-vars)
 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))
 225                                  (cdr prop-element)))
 226                  element-list)
 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)
 230                           (let ((index -1))
 231                             (append-map (lambda (e)
 232                                           (set! index (1+ index))
 233                                           (if (var? e)
 234                                               `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index)))
 235                                               (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements))
 236                                                                        ,index)
 237                                                             e)))
 238                                         (cdr prop-elements))))
 239                         elements-list))))
 240
 241 (define-macro (with-music-match music-expr+pattern . body)
 242   "If `music-expr' matches `pattern', call `body'. `pattern' should look like:
 243   '(music <MusicType>
 244      property value
 245      property ?var1
 246      element (music <MusicType> ...)
 247      elements ((music <MusicType> ...)
 248                ?var2
 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
 253 or 'elements).
 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
 257 inside body."
 258   (let ((music-expr (first music-expr+pattern))
 259         (pattern (second music-expr+pattern))
 260         (expr-sym (gensym)))
 261     `(let ((,expr-sym ,music-expr))
 262        (if ,(gen-condition expr-sym pattern)
 263            (let ,(gen-bindings expr-sym pattern)
 264              ,@body)
 265            #f))))
 266
 267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 268 ;;;
 269 ;;; Special parameters
 270 ;;;
 271
 272 ;;; indentation
 273 (define *indent* (make-parameter 0))
 274
 275 ;;; set to #t to force duration printing
 276 (define *force-duration* (make-parameter #f))
 277
 278 ;;; last duration found
 279 (define *previous-duration* (make-parameter (ly:make-duration 2)))
 280
 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))
 284
 285 ;; \times factor (used in durations)
 286 (define *time-factor-denominator* (make-parameter #f))
 287 (define *time-factor-numerator* (make-parameter #f))
 288
 289 (define *parser* (make-parameter #f))
 290
 291 (define *current-context* (make-parameter 'Bottom))
 292
 293 (define *explicit-mode* (make-parameter #t))
 294
 295 (define (new-line->lily-string)
 296   (format #f "~%~v_" (max 0 (1- (*indent*)))))
 297
 298 ;;;
 299 ;;; music type predicate maker
 300 ;;;
 301
 302 (define (make-music-type-predicate . music-types)
 303   (define ((make-music-type-predicate-aux mtypes) expr)
 304     (if (null? mtypes)
 305         #f
 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))
 309
 310 (load "define-music-display-methods.scm")