scm/song-util.scm

   1 ;;;; song-util.scm --- Festival singing mode output
   2 ;;;;
   3 ;;;; This file is part of LilyPond, the GNU music typesetter.
   4 ;;;;
   5 ;;;; Copyright (C) 2006, 2007 Brailcom, o.p.s.
   6 ;;;; Author: Milan Zamazal <pdm@brailcom.org>
   7 ;;;;
   8 ;;;; LilyPond is free software: you can redistribute it and/or modify
   9 ;;;; it under the terms of the GNU General Public License as published by
  10 ;;;; the Free Software Foundation, either version 3 of the License, or
  11 ;;;; (at your option) any later version.
  12 ;;;;
  13 ;;;; LilyPond is distributed in the hope that it will be useful,
  14 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;;; GNU General Public License for more details.
  17 ;;;;
  18 ;;;; You should have received a copy of the GNU General Public License
  19 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  20
  21
  22 (define-module (scm song-util))
  23
  24 (use-modules (srfi srfi-1))
  25 (use-modules (ice-9 optargs))
  26 (use-modules (ice-9 pretty-print))
  27
  28 (use-modules (lily))
  29
  30
  31 ;;; Debugging utilities
  32
  33
  34 ;; Iff true, enable a lot of debugging output
  35 (define-public *debug* #f)
  36
  37 (define-macro (assert condition . data)
  38   (if *debug*
  39       `(if (not ,condition)
  40            (error "Assertion failed" (quote ,condition) ,@data))
  41       #f))
  42 (export assert)
  43
  44 (define-macro (debug message object)
  45   (if *debug*
  46       `(debug* ,message ,object)
  47       object))
  48 (export debug)
  49
  50 (define (debug* message object)
  51   (display "[[") (display message) (display "]] ") (pretty-print object)
  52   object)
  53
  54
  55 ;;; General utilities
  56
  57
  58 (define-macro (defstruct name . slots)
  59   ;; Similar as in Common Lisp, but much simplier -- no structure and slot options, no docstring
  60   (let* ((slots* (map (lambda (s) (if (pair? s) s (list s))) slots))
  61          (make-symbol (lambda (format% . extra-args)
  62                         (string->symbol (apply format #f format% name extra-args))))
  63          ($record? (make-symbol "~a?"))
  64          ($make-record (make-symbol "make-~a"))
  65          ($copy-record (make-symbol "copy-~a"))
  66          (reader-format "~a-~a")
  67          (writer-format "set-~a-~a!")
  68          (record (gensym)))
  69     `(begin
  70        (define ,$record? #f)
  71        (define ,$make-record #f)
  72        (define ,$copy-record #f)
  73        ,@(map (lambda (s) `(define ,(make-symbol reader-format (car s)) #f)) slots*)
  74        ,@(map (lambda (s) `(define ,(make-symbol writer-format (car s)) #f)) slots*)
  75        (let ((,record ,(make-record-type name (map car slots*))))
  76          (set! ,$record?
  77                (lambda (record) ((record-predicate ,record) record)))
  78          (set! ,$make-record
  79                (lambda* (#:key ,@slots)
  80                  ((record-constructor ,record) ,@(map car slots*))))
  81          (set! ,$copy-record
  82                (lambda (record)
  83                  (,$make-record ,@(apply
  84                                    append
  85                                    (map (lambda (slot)
  86                                           (list (symbol->keyword slot)
  87                                                 (list (make-symbol reader-format slot) 'record)))
  88                                         (map car slots*))))))
  89          ,@(map (lambda (s)
  90                   `(set! ,(make-symbol reader-format (car s))
  91                          (record-accessor ,record (quote ,(car s)))))
  92                 slots*)
  93          ,@(map (lambda (s)
  94                   `(set! ,(make-symbol writer-format (car s))
  95                          (record-modifier ,record (quote ,(car s)))))
  96                 slots*)))))
  97 (export defstruct)
  98
  99 (define-public (compose . functions)
 100   (let ((functions* (drop-right functions 1))
 101         (last-function (last functions)))
 102     (letrec ((reduce (lambda (x functions)
 103                        (if (null? functions)
 104                            x
 105                            (reduce ((car functions) x) (cdr functions))))))
 106       (lambda args (reduce (apply (last functions) args) (reverse functions*))))))
 107
 108 (define-macro (push! object list-var)
 109   ;; The same as in Common Lisp
 110   `(set! ,list-var (cons ,object ,list-var)))
 111 (export push!)
 112
 113 (define-macro (add! object list-var)
 114   `(set! ,list-var (append ,list-var (list ,object))))
 115 (export add!)
 116
 117 (define-public (safe-car list)
 118   (if (null? list)
 119       #f
 120       (car list)))
 121
 122 (define-public (safe-last list)
 123   (if (null? list)
 124       #f
 125       (last list)))
 126
 127
 128 ;;; LilyPond utility functions
 129
 130
 131 (define-public (music-property-value? music property value)
 132   "Return @code{#t} iff @var{music}'s @var{property} is equal to
 133 @var{value}."
 134   (equal? (ly:music-property music property) value))
 135
 136 (define-public (music-name? music name)
 137   "Return @code{#t} iff @var{music}'s name is @var{name}."
 138   (if (list? name)
 139       (member (ly:music-property music 'name) name)
 140       (music-property-value? music 'name name)))
 141
 142 (define-public (music-property? music property)
 143   "Return @code{#t} iff @var{music} is a property setter and sets
 144 or unsets @var{property}."
 145   (and (music-name? music '(PropertySet PropertyUnset))
 146        (music-property-value? music 'symbol property)))
 147
 148 (define-public (music-has-property? music property)
 149   "Return @code{#t} iff @var{music} contains @var{property}."
 150   (not (eq? (ly:music-property music property) '())))
 151
 152 (define-public (property-value music)
 153   "Return value of a property setter @var{music}.
 154 If it unsets the property, return @code{#f}."
 155   (if (music-name? music 'PropertyUnset)
 156       #f
 157       (ly:music-property music 'value)))
 158
 159 (define-public (music-elements music)
 160   "Return list of all @var{music}'s top-level children."
 161   (let ((elt (ly:music-property music 'element))
 162         (elts (ly:music-property music 'elements))
 163         (arts (ly:music-property music 'articulations)))
 164     (if (pair? arts)
 165         (set! elts (append elts arts)))
 166     (if (null? elt)
 167         elts
 168         (cons elt elts))))
 169
 170 (define-public (find-child music predicate)
 171   "Find the first node in @var{music} that satisfies @var{predicate}."
 172   (define (find-child queue)
 173     (if (null? queue)
 174         #f
 175         (let ((elt (car queue)))
 176           (if (predicate elt)
 177               elt
 178               (find-child (append (music-elements elt) (cdr queue)))))))
 179   (find-child (list music)))
 180
 181 (define-public (find-child-named music name)
 182   "Return the first child in @var{music} that is named @var{name}."
 183   (find-child music (lambda (elt) (music-name? elt name))))
 184
 185 (define-public (process-music music function)
 186   "Process all nodes of @var{music} (including @var{music}) in the DFS order.
 187 Apply @var{function} on each of the nodes.  If @var{function} applied on a
 188 node returns @code{#t}, don't process the node's subtree.
 189
 190 If a non-boolean is returned, it is considered the material to recurse."
 191   (define (process-music queue)
 192     (if (not (null? queue))
 193         (let* ((elt (car queue))
 194                (stop (function elt)))
 195           (process-music (if (boolean? stop)
 196                              (if stop
 197                                  (cdr queue)
 198                                  (append (music-elements elt) (cdr queue)))
 199                              ((if (cheap-list? stop) append cons)
 200                               stop (cdr queue)))))))
 201   (process-music (list music)))