scm/display-lily.scm

   1 ;;; display-lily.scm -- Display music expressions using LilyPond notation
   2 ;;;
   3 ;;;
   4 ;;;
   5 ;;; Copyright (C) 2005--2012 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 ;;; - `music->lily-string' return a string describing a music expression using
  15 ;;; LilyPond notation. The special variables *indent*, *previous-duration*,
  16 ;;; and *force-duration* influence the indentation level and the display of
  17 ;;; music durations.
  18 ;;;
  19 ;;; - `with-music-match' can be used to destructure a music expression, extracting
  20 ;;; some interesting music properties.
  21
  22
  23 (define-module (scm display-lily)
  24   #:use-module (ice-9 optargs)
  25   #:use-module (ice-9 format)
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 pretty-print)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-13)
  30   #:use-module (srfi srfi-39)
  31   #:use-module (lily))
  32
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;;;
  35 ;;; Display method definition and call
  36 ;;;
  37
  38
  39 (define-macro (define-display-method music-type vars . body)
  40   "Define a display method for a music type and store it in the
  41 `display-methods' property of the music type entry found in the
  42 `music-name-to-property-table' hash table.  Print methods previously
  43 defined for that music type are lost.
  44 Syntax: (define-display-method MusicType (expression parser)
  45           ...body...))"
  46   `(let ((type-props (hashq-ref music-name-to-property-table
  47                                 ',music-type '()))
  48          (method (lambda ,vars
  49                    ,@body)))
  50      (set! type-props
  51            (assoc-set! type-props 'display-methods (list method)))
  52      (hashq-set! music-name-to-property-table
  53                  ',music-type
  54                  type-props)
  55      method))
  56
  57 (define-macro (define-extra-display-method music-type vars . body)
  58   "Add a display method for a music type.  A primary display method
  59 is supposed to have been previously defined with `define-display-method'.
  60 This new method should return a string or #f.  If #f is returned, the next
  61 display method will be called."
  62   `(let* ((type-props (hashq-ref music-name-to-property-table
  63                                  ',music-type '()))
  64           (methods (assoc-ref type-props 'display-methods))
  65           (new-method (lambda ,vars
  66                         ,@body)))
  67      (set! type-props
  68            (assoc-set! type-props
  69                        'display-methods
  70                        (cons new-method methods)))
  71      (hashq-set! music-name-to-property-table
  72                  ',music-type
  73                  type-props)
  74      new-method))
  75
  76 (define* (tag->lily-string expr #:optional (post-event? #f))
  77   (format #f "~{~a ~}"
  78           (map (lambda (tag)
  79                  (format #f "~a\\tag #'~a" (if post-event? "-" "") tag))
  80                (ly:music-property expr 'tags))))
  81
  82 (define* (tweaks->lily-string expr #:optional (post-event? #f))
  83   (format #f "~{~a ~}"
  84           (map (lambda (tweak)
  85                  (let ((addr (car tweak))
  86                        (val (cdr tweak)))
  87                    (format #f "~a\\tweak ~a #~a"
  88                            (if post-event? "-" "")
  89                            (cond
  90                             ((symbol? addr)
  91                              (format #f "~a" addr))
  92                             ((symbol? (cdr addr))
  93                              (format #f "~a.~a" (car addr) (cdr addr)))
  94                             (else
  95                              (format #f "~{~a~^.~}"
  96                                      (if (symbol? (car addr))
  97                                          addr
  98                                          (cdr addr)))))
  99                            (scheme-expr->lily-string val))))
 100                (ly:music-property expr 'tweaks))))
 101
 102 (define-public (music->lily-string expr parser)
 103   "Print @var{expr}, a music expression, in LilyPond syntax."
 104   (if (ly:music? expr)
 105       (let* ((music-type (ly:music-property expr 'name))
 106              (procs (assoc-ref (hashq-ref music-name-to-property-table
 107                                           music-type '())
 108                                'display-methods))
 109              (result-string (and procs (any (lambda (proc)
 110                                               (proc expr parser))
 111                                             procs))))
 112         (if result-string
 113             (format #f "~a~a~a"
 114                     (tag->lily-string expr (post-event? expr))
 115                     (tweaks->lily-string expr (post-event? expr))
 116                     result-string)
 117             (format #f "%{ Print method not implemented for music type ~a %}"
 118                     music-type)))
 119       (format #f "%{ expecting a music expression: ~a %}" expr)))
 120
 121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 122 ;;;
 123 ;;; Music pattern matching
 124 ;;;
 125
 126 (define (var? x)
 127   (and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0))))
 128
 129 (define (music? x)
 130   (and (pair? x) (eqv? (car x) 'music)))
 131
 132 (define (music-list? x)
 133   (and (pair? x)
 134        (every music? x)))
 135
 136 (define (music-or-var-list? x)
 137   (and (pair? x)
 138        (every (lambda (e)
 139                 (or (music? e) (var? e)))
 140               x)))
 141
 142 (define (key-val-list->alist lst)
 143   (define (key-val-list->alist-aux lst prev-result)
 144     (if (null? lst)
 145         prev-result
 146         (key-val-list->alist-aux (cddr lst)
 147                                  (cons (cons (first lst) (second lst))
 148                                        prev-result))))
 149   (reverse! (key-val-list->alist-aux lst (list))))
 150
 151 (define (gen-condition expr pattern)
 152   "Helper function for `with-music-match'.
 153 Generate an form that checks if the properties of `expr'
 154 match thoses described in `pattern'."
 155   (let* (;; all (property . value) found at the first depth in pattern,
 156          ;; including a (name . <Musictype>) pair.
 157          (pat-all-props (cons (cons 'name (second pattern))
 158                               (key-val-list->alist (cddr pattern))))
 159          ;; all (property . value) pairs found in pattern, where value is not
 160          ;; a ?var, a music expression or a music list.
 161          (prop-vals (remove (lambda (kons)
 162                               (or (var? (cdr kons))
 163                                   (music? (cdr kons))
 164                                   (music-or-var-list? (cdr kons))))
 165                             pat-all-props))
 166          ;; list of (property . element) pairs, where element is a music expression
 167          (element-list (filter (lambda (kons) (music? (cdr kons)))
 168                                pat-all-props))
 169          ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
 170          ;; list a music expressions
 171          (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
 172                                 pat-all-props)))
 173     `(and
 174       ;; a form that checks that `expr' is a music expression
 175       ;; before actually accessing its properties...
 176       (ly:music? ,expr)
 177       ;; a form that checks that `expr' properties have the same
 178       ;; values as those given in `pattern'
 179       ,@(map (lambda (prop-val)
 180                (let ((prop (car prop-val))
 181                      (val (cdr prop-val)))
 182                  `(and (not (null? (ly:music-property ,expr ',prop)))
 183                        (equal? (ly:music-property ,expr ',prop) ,val))))
 184              prop-vals)
 185       ;; build the test condition for each element found in a (property . element) pair.
 186       ;; (typically, property will be 'element)
 187       ,@(map (lambda (prop-element)
 188                (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element)))
 189              element-list)
 190       ;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair.
 191       ;; this requires accessing to an element of a list, hence the index.
 192       ;; (typically, property will be 'elements)
 193       ,@(map (lambda (prop-elements)
 194                (let ((ges (gensym))
 195                      (index -1))
 196                  `(and ,@(map (lambda (e)
 197                                 (set! index (1+ index))
 198                                 (if (music? e)
 199                                     (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements)))
 200                                                             ,index)
 201                                                          (list-ref (ly:music-property ,expr ',(car prop-elements))
 202                                                                    ,index))
 203                                                    e)
 204                                     #t))
 205                               (cdr prop-elements)))))
 206              elements-list))))
 207
 208 (define (gen-bindings expr pattern)
 209   "Helper function for `with-music-match'.
 210 Generate binding forms by looking for ?var symbol in pattern."
 211   (let* (;; all (property . value) found at the first depth of pattern,
 212          ;; including a (name . <Musictype>) pair.
 213          (pat-all-props (cons (cons 'name (second pattern))
 214                               (key-val-list->alist (cddr pattern))))
 215          ;; all (property . ?var) pairs
 216          (prop-vars (filter (lambda (kons) (var? (cdr kons)))
 217                             pat-all-props))
 218          ;; list of (property . element) pairs, where element is a music expression
 219          (element-list (filter (lambda (kons) (music? (cdr kons)))
 220                                pat-all-props))
 221          ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
 222          ;; list a music expressions
 223          (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
 224                                 pat-all-props)))
 225     (append
 226      ;; the binding form for the ?var variable found in pattern (first depth).
 227      ;; ?var is bound to the value of `expr' property
 228      (map (lambda (prop-var)
 229             `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var))))
 230           prop-vars)
 231      ;; generate bindings for each element found in a (property . element) pair.
 232      ;; (typically, property will be 'element)
 233      (append-map (lambda (prop-element)
 234                    (gen-bindings `(ly:music-property ,expr ',(car prop-element))
 235                                  (cdr prop-element)))
 236                  element-list)
 237      ;; generate bindings for each element found in a (property . (e1 e2 ...)) pair
 238      ;; (typically, property will be 'elements)
 239      (append-map (lambda (prop-elements)
 240                    (let ((index -1))
 241                      (append-map (lambda (e)
 242                                    (set! index (1+ index))
 243                                    (if (var? e)
 244                                        `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index)))
 245                                        (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements))
 246                                                                 ,index)
 247                                                      e)))
 248                                  (cdr prop-elements))))
 249                  elements-list))))
 250
 251 (define-macro (with-music-match music-expr+pattern . body)
 252   "If `music-expr' matches `pattern', call `body'.  `pattern' should look like:
 253   '(music <MusicType>
 254      property value
 255      property ?var1
 256      element (music <MusicType> ...)
 257      elements ((music <MusicType> ...)
 258                ?var2
 259                (music <MusicType> ...)))
 260 The properties of `music-expr' are checked against the values given in the
 261 pattern (the name property being the <MusicType> symbol after the `music'
 262 keyword), then all music expression found in its properties (such as 'element
 263 or 'elements).
 264 When ?var is found instead of a property value, ?var is bound that property value,
 265 as read inside `music-expr'.  ?var may also be used to refere to a whole music
 266 expression inside an elements list for instance.  These bindings are accessible
 267 inside body."
 268   (let ((music-expr (first music-expr+pattern))
 269         (pattern (second music-expr+pattern))
 270         (expr-sym (gensym)))
 271     `(let ((,expr-sym ,music-expr))
 272        (if ,(gen-condition expr-sym pattern)
 273            (let ,(gen-bindings expr-sym pattern)
 274              ,@body)
 275            #f))))
 276
 277 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 278 ;;;
 279 ;;; Special parameters
 280 ;;;
 281
 282 ;;; indentation
 283 (define-public *indent* (make-parameter 0))
 284
 285 ;;; set to #t to force duration printing
 286 (define-public *force-duration* (make-parameter #f))
 287
 288 ;;; last duration found
 289 (define-public *previous-duration* (make-parameter (ly:make-duration 2)))
 290
 291 ;;; Set to #t to force a line break with some kinds of expressions (eg sequential music)
 292 (define *force-line-break* (make-parameter #t))
 293 (define *max-element-number-before-break* (make-parameter 6))
 294
 295 ;; \times factor (used in durations)
 296 (define *time-scale* (make-parameter 1))
 297
 298 (define *current-context* (make-parameter 'Bottom))
 299
 300 (define *explicit-mode* (make-parameter #t))
 301
 302 (define (new-line->lily-string)
 303   (format #f "~%~v_" (max 0 (1- (*indent*)))))
 304
 305 ;;;
 306 ;;; music type predicate maker
 307 ;;;
 308
 309 (define (make-music-type-predicate . music-types)
 310   (define make-music-type-predicate-aux
 311     (lambda (mtypes)
 312       (lambda (expr)
 313         (if (null? mtypes)
 314             #f
 315             (or (eqv? (car mtypes) (ly:music-property expr 'name))
 316                 ((make-music-type-predicate-aux (cdr mtypes)) expr))))))
 317   (make-music-type-predicate-aux music-types))
 318
 319 (ly:load "define-music-display-methods.scm")