X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdisplay-lily.scm;h=b5a7cff139c58dfca945397ebfff5d7283f327ff;hb=a6a51abfd0195a3cf7d6ea095cf69808852f21ce;hp=058534acfe6812a52d844eb24ff29e6e42bd24c5;hpb=73d3a7eacc32f58d4c0215709652bd4470243321;p=lilypond.git diff --git a/scm/display-lily.scm b/scm/display-lily.scm index 058534acfe..b5a7cff139 100644 --- a/scm/display-lily.scm +++ b/scm/display-lily.scm @@ -2,7 +2,7 @@ ;;; ;;; ;;; -;;; Copyright (C) 2005--2012 Nicolas Sceaux +;;; Copyright (C) 2005--2015 Nicolas Sceaux ;;; ;;; - This file defines the procedures used to define display methods for each @@ -11,10 +11,10 @@ ;;; Display methods are stored in the `display-methods' property of each music ;;; type. ;;; -;;; - `music->lily-string' return a string describing a music expression using -;;; LilyPond notation. The special variables *indent*, *previous-duration*, -;;; and *force-duration* influence the indentation level and the display of -;;; music durations. +;;; - `music->lily-string' return a string describing a music +;;; expression using LilyPond notation. The special variables *indent* +;;; and *omit-duration* influence the indentation level and the +;;; display of music durations. ;;; ;;; - `with-music-match' can be used to destructure a music expression, extracting ;;; some interesting music properties. @@ -40,18 +40,18 @@ "Define a display method for a music type and store it in the `display-methods' property of the music type entry found in the `music-name-to-property-table' hash table. Print methods previously -defined for that music type are lost. -Syntax: (define-display-method MusicType (expression parser) - ...body...))" +defined for that music type are lost. +Syntax: (define-display-method MusicType (expression) + ...body...))" `(let ((type-props (hashq-ref music-name-to-property-table - ',music-type '())) - (method (lambda ,vars - ,@body))) + ',music-type '())) + (method (lambda ,vars + ,@body))) (set! type-props - (assoc-set! type-props 'display-methods (list method))) + (assoc-set! type-props 'display-methods (list method))) (hashq-set! music-name-to-property-table - ',music-type - type-props) + ',music-type + type-props) method)) (define-macro (define-extra-display-method music-type vars . body) @@ -60,60 +60,68 @@ is supposed to have been previously defined with `define-display-method'. This new method should return a string or #f. If #f is returned, the next display method will be called." `(let* ((type-props (hashq-ref music-name-to-property-table - ',music-type '())) - (methods (assoc-ref type-props 'display-methods)) - (new-method (lambda ,vars - ,@body))) + ',music-type '())) + (methods (assoc-ref type-props 'display-methods)) + (new-method (lambda ,vars + ,@body))) (set! type-props - (assoc-set! type-props - 'display-methods - (cons new-method methods))) + (assoc-set! type-props + 'display-methods + (cons new-method methods))) (hashq-set! music-name-to-property-table - ',music-type - type-props) + ',music-type + type-props) new-method)) (define* (tag->lily-string expr #:optional (post-event? #f)) (format #f "~{~a ~}" - (map (lambda (tag) - (format #f "~a\\tag #'~a" (if post-event? "-" "") tag)) - (ly:music-property expr 'tags)))) + (map (lambda (tag) + (format #f "~a\\tag #'~a" (if post-event? "-" "") tag)) + (ly:music-property expr 'tags)))) (define* (tweaks->lily-string expr #:optional (post-event? #f)) (format #f "~{~a ~}" (map (lambda (tweak) - (format #f "~a\\tweak ~a #~a" - (if post-event? "-" "") - (if (pair? (car tweak)) - (format #f "~a #'~a" - (caar tweak) (cdar tweak)) - (format #f "#'~a" (car tweak))) - (scheme-expr->lily-string (cdr tweak)))) + (let ((addr (car tweak)) + (val (cdr tweak))) + (format #f "~a\\tweak ~a #~a" + (if post-event? "-" "") + (cond + ((symbol? addr) + (format #f "~a" addr)) + ((symbol? (cdr addr)) + (format #f "~a.~a" (car addr) (cdr addr))) + (else + (format #f "~{~a~^.~}" + (if (symbol? (car addr)) + addr + (cdr addr))))) + (scheme-expr->lily-string val)))) (ly:music-property expr 'tweaks)))) -(define-public (music->lily-string expr parser) +(define-public (music->lily-string expr) "Print @var{expr}, a music expression, in LilyPond syntax." (if (ly:music? expr) (let* ((music-type (ly:music-property expr 'name)) - (procs (assoc-ref (hashq-ref music-name-to-property-table - music-type '()) - 'display-methods)) - (result-string (and procs (any (lambda (proc) - (proc expr parser)) - procs)))) - (if result-string - (format #f "~a~a~a" + (procs (assoc-ref (hashq-ref music-name-to-property-table + music-type '()) + 'display-methods)) + (result-string (and procs (any (lambda (proc) + (proc expr)) + procs)))) + (if result-string + (format #f "~a~a~a" (tag->lily-string expr (post-event? expr)) (tweaks->lily-string expr (post-event? expr)) - result-string) - (format #f "%{ Print method not implemented for music type ~a %}" - music-type))) + result-string) + (format #f "%{ Print method not implemented for music type ~a %}" + music-type))) (format #f "%{ expecting a music expression: ~a %}" expr))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Music pattern matching -;;; +;;; (define (var? x) (and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0)))) @@ -128,16 +136,16 @@ display method will be called." (define (music-or-var-list? x) (and (pair? x) (every (lambda (e) - (or (music? e) (var? e))) - x))) + (or (music? e) (var? e))) + x))) (define (key-val-list->alist lst) (define (key-val-list->alist-aux lst prev-result) (if (null? lst) - prev-result - (key-val-list->alist-aux (cddr lst) - (cons (cons (first lst) (second lst)) - prev-result)))) + prev-result + (key-val-list->alist-aux (cddr lst) + (cons (cons (first lst) (second lst)) + prev-result)))) (reverse! (key-val-list->alist-aux lst (list)))) (define (gen-condition expr pattern) @@ -145,126 +153,123 @@ display method will be called." Generate an form that checks if the properties of `expr' match thoses described in `pattern'." (let* (;; all (property . value) found at the first depth in pattern, - ;; including a (name . ) pair. - (pat-all-props (cons (cons 'name (second pattern)) - (key-val-list->alist (cddr pattern)))) - ;; all (property . value) pairs found in pattern, where value is not - ;; a ?var, a music expression or a music list. - (prop-vals (remove (lambda (kons) - (or (var? (cdr kons)) - (music? (cdr kons)) - (music-or-var-list? (cdr kons)))) - pat-all-props)) - ;; list of (property . element) pairs, where element is a music expression - (element-list (filter (lambda (kons) (music? (cdr kons))) - pat-all-props)) - ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a - ;; list a music expressions - (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) - pat-all-props))) - `(and + ;; including a (name . ) pair. + (pat-all-props (cons (cons 'name (second pattern)) + (key-val-list->alist (cddr pattern)))) + ;; all (property . value) pairs found in pattern, where value is not + ;; a ?var, a music expression or a music list. + (prop-vals (remove (lambda (kons) + (or (var? (cdr kons)) + (music? (cdr kons)) + (music-or-var-list? (cdr kons)))) + pat-all-props)) + ;; list of (property . element) pairs, where element is a music expression + (element-list (filter (lambda (kons) (music? (cdr kons))) + pat-all-props)) + ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a + ;; list a music expressions + (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) + pat-all-props))) + `(and ;; a form that checks that `expr' is a music expression ;; before actually accessing its properties... (ly:music? ,expr) ;; a form that checks that `expr' properties have the same ;; values as those given in `pattern' ,@(map (lambda (prop-val) - (let ((prop (car prop-val)) - (val (cdr prop-val))) - `(and (not (null? (ly:music-property ,expr ',prop))) - (equal? (ly:music-property ,expr ',prop) ,val)))) - prop-vals) + (let ((prop (car prop-val)) + (val (cdr prop-val))) + `(and (not (null? (ly:music-property ,expr ',prop))) + (equal? (ly:music-property ,expr ',prop) ,val)))) + prop-vals) ;; build the test condition for each element found in a (property . element) pair. ;; (typically, property will be 'element) ,@(map (lambda (prop-element) - (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element))) - element-list) + (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element))) + element-list) ;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair. ;; this requires accessing to an element of a list, hence the index. ;; (typically, property will be 'elements) - ,@(map (lambda (prop-elements) - (let ((ges (gensym)) - (index -1)) - `(and ,@(map (lambda (e) - (set! index (1+ index)) - (if (music? e) - (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements))) - ,index) - (list-ref (ly:music-property ,expr ',(car prop-elements)) - ,index)) - e) - #t)) - (cdr prop-elements))))) - elements-list)))) + ,@(map + (lambda (prop-elements) + (let ((ges (gensym)) + (len (length (cdr prop-elements)))) + `(let ((,ges (ly:music-property ,expr ',(car prop-elements)))) + (and (eqv? (length+ ,ges) ,len) + ,@(filter-map + (lambda (e index) + (and (music? e) + (gen-condition `(list-ref ,ges ,index) e))) + (cdr prop-elements) (iota len)))))) + elements-list)))) (define (gen-bindings expr pattern) "Helper function for `with-music-match'. Generate binding forms by looking for ?var symbol in pattern." (let* (;; all (property . value) found at the first depth of pattern, - ;; including a (name . ) pair. - (pat-all-props (cons (cons 'name (second pattern)) - (key-val-list->alist (cddr pattern)))) - ;; all (property . ?var) pairs - (prop-vars (filter (lambda (kons) (var? (cdr kons))) - pat-all-props)) - ;; list of (property . element) pairs, where element is a music expression - (element-list (filter (lambda (kons) (music? (cdr kons))) - pat-all-props)) - ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a - ;; list a music expressions - (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) - pat-all-props))) - (append + ;; including a (name . ) pair. + (pat-all-props (cons (cons 'name (second pattern)) + (key-val-list->alist (cddr pattern)))) + ;; all (property . ?var) pairs + (prop-vars (filter (lambda (kons) (var? (cdr kons))) + pat-all-props)) + ;; list of (property . element) pairs, where element is a music expression + (element-list (filter (lambda (kons) (music? (cdr kons))) + pat-all-props)) + ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a + ;; list a music expressions + (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) + pat-all-props))) + (append ;; the binding form for the ?var variable found in pattern (first depth). ;; ?var is bound to the value of `expr' property (map (lambda (prop-var) - `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var)))) - prop-vars) + `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var)))) + prop-vars) ;; generate bindings for each element found in a (property . element) pair. ;; (typically, property will be 'element) (append-map (lambda (prop-element) - (gen-bindings `(ly:music-property ,expr ',(car prop-element)) - (cdr prop-element))) - element-list) + (gen-bindings `(ly:music-property ,expr ',(car prop-element)) + (cdr prop-element))) + element-list) ;; generate bindings for each element found in a (property . (e1 e2 ...)) pair ;; (typically, property will be 'elements) - (append-map (lambda (prop-elements) - (let ((index -1)) - (append-map (lambda (e) - (set! index (1+ index)) - (if (var? e) - `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index))) - (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements)) - ,index) - e))) - (cdr prop-elements)))) - elements-list)))) - -(define-macro (with-music-match music-expr+pattern . body) + (append-map (lambda (prop-elements) + (let ((index -1)) + (append-map (lambda (e) + (set! index (1+ index)) + (if (var? e) + `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index))) + (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements)) + ,index) + e))) + (cdr prop-elements)))) + elements-list)))) + +(defmacro-public with-music-match (music-expr+pattern . body) "If `music-expr' matches `pattern', call `body'. `pattern' should look like: '(music property value property ?var1 element (music ...) elements ((music ...) - ?var2 - (music ...))) + ?var2 + (music ...))) The properties of `music-expr' are checked against the values given in the pattern (the name property being the symbol after the `music' keyword), then all music expression found in its properties (such as 'element or 'elements). When ?var is found instead of a property value, ?var is bound that property value, -as read inside `music-expr'. ?var may also be used to refere to a whole music -expression inside an elements list for instance. These bindings are accessible +as read inside `music-expr'. ?var may also be used to refere to a whole music +expression inside an elements list for instance. These bindings are accessible inside body." (let ((music-expr (first music-expr+pattern)) - (pattern (second music-expr+pattern)) - (expr-sym (gensym))) + (pattern (second music-expr+pattern)) + (expr-sym (gensym))) `(let ((,expr-sym ,music-expr)) - (if ,(gen-condition expr-sym pattern) - (let ,(gen-bindings expr-sym pattern) - ,@body) - #f)))) + (and ,(gen-condition expr-sym pattern) + (let ,(gen-bindings expr-sym pattern) + ,@body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -274,19 +279,15 @@ inside body." ;;; indentation (define-public *indent* (make-parameter 0)) -;;; set to #t to force duration printing -(define-public *force-duration* (make-parameter #f)) - -;;; last duration found -(define-public *previous-duration* (make-parameter (ly:make-duration 2))) +;;; set to #t to omit duration printing +(define-public *omit-duration* (make-parameter #f)) ;;; Set to #t to force a line break with some kinds of expressions (eg sequential music) (define *force-line-break* (make-parameter #t)) (define *max-element-number-before-break* (make-parameter 6)) ;; \times factor (used in durations) -(define *time-factor-denominator* (make-parameter #f)) -(define *time-factor-numerator* (make-parameter #f)) +(define *time-scale* (make-parameter 1)) (define *current-context* (make-parameter 'Bottom)) @@ -303,11 +304,10 @@ inside body." (define make-music-type-predicate-aux (lambda (mtypes) (lambda (expr) - (if (null? mtypes) - #f - (or (eqv? (car mtypes) (ly:music-property expr 'name)) - ((make-music-type-predicate-aux (cdr mtypes)) expr)))))) - (make-music-type-predicate-aux music-types)) + (if (null? mtypes) + #f + (or (eqv? (car mtypes) (ly:music-property expr 'name)) + ((make-music-type-predicate-aux (cdr mtypes)) expr)))))) + (make-music-type-predicate-aux music-types)) (ly:load "define-music-display-methods.scm") -