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 ,@(append-map
  84                                    (lambda (slot)
  85                                      (list (symbol->keyword slot)
  86                                            (list (make-symbol reader-format slot) 'record)))
  87                                    (map car slots*)))))
  88          ,@(map (lambda (s)
  89                   `(set! ,(make-symbol reader-format (car s))
  90                          (record-accessor ,record (quote ,(car s)))))
  91                 slots*)
  92          ,@(map (lambda (s)
  93                   `(set! ,(make-symbol writer-format (car s))
  94                          (record-modifier ,record (quote ,(car s)))))
  95                 slots*)))))
  96 (export defstruct)
  97
  98 (define-public (compose . functions)
  99   (let ((functions* (drop-right functions 1))
 100         (last-function (last functions)))
 101     (letrec ((reduce (lambda (x functions)
 102                        (if (null? functions)
 103                            x
 104                            (reduce ((car functions) x) (cdr functions))))))
 105       (lambda args (reduce (apply (last functions) args) (reverse functions*))))))
 106
 107 (define-macro (push! object list-var)
 108   ;; The same as in Common Lisp
 109   `(set! ,list-var (cons ,object ,list-var)))
 110 (export push!)
 111
 112 (define-macro (add! object list-var)
 113   `(set! ,list-var (append ,list-var (list ,object))))
 114 (export add!)
 115
 116 (define-public (safe-car list)
 117   (if (null? list)
 118       #f
 119       (car list)))
 120
 121 (define-public (safe-last list)
 122   (if (null? list)
 123       #f
 124       (last list)))
 125
 126
 127 ;;; LilyPond utility functions
 128
 129
 130 (define-public (music-property-value? music property value)
 131   "Return @code{#t} iff @var{music}'s @var{property} is equal to
 132 @var{value}."
 133   (equal? (ly:music-property music property) value))
 134
 135 (define-public (music-name? music name)
 136   "Return @code{#t} iff @var{music}'s name is @var{name}."
 137   (if (list? name)
 138       (member (ly:music-property music 'name) name)
 139       (music-property-value? music 'name name)))
 140
 141 (define-public (music-property? music property)
 142   "Return @code{#t} iff @var{music} is a property setter and sets
 143 or unsets @var{property}."
 144   (and (music-name? music '(PropertySet PropertyUnset))
 145        (music-property-value? music 'symbol property)))
 146
 147 (define-public (music-has-property? music property)
 148   "Return @code{#t} iff @var{music} contains @var{property}."
 149   (not (eq? (ly:music-property music property) '())))
 150
 151 (define-public (property-value music)
 152   "Return value of a property setter @var{music}.
 153 If it unsets the property, return @code{#f}."
 154   (if (music-name? music 'PropertyUnset)
 155       #f
 156       (ly:music-property music 'value)))
 157
 158 (define-public (music-elements music)
 159   "Return list of all @var{music}'s top-level children."
 160   (let ((elt (ly:music-property music 'element))
 161         (elts (ly:music-property music 'elements))
 162         (arts (ly:music-property music 'articulations)))
 163     (if (pair? arts)
 164         (set! elts (append elts arts)))
 165     (if (null? elt)
 166         elts
 167         (cons elt elts))))
 168
 169 (define-public (find-child music predicate)
 170   "Find the first node in @var{music} that satisfies @var{predicate}."
 171   (define (find-child queue)
 172     (if (null? queue)
 173         #f
 174         (let ((elt (car queue)))
 175           (if (predicate elt)
 176               elt
 177               (find-child (append (music-elements elt) (cdr queue)))))))
 178   (find-child (list music)))
 179
 180 (define-public (find-child-named music name)
 181   "Return the first child in @var{music} that is named @var{name}."
 182   (find-child music (lambda (elt) (music-name? elt name))))
 183
 184 (define-public (process-music music function)
 185   "Process all nodes of @var{music} (including @var{music}) in the DFS order.
 186 Apply @var{function} on each of the nodes.  If @var{function} applied on a
 187 node returns @code{#t}, don't process the node's subtree.
 188
 189 If a non-boolean is returned, it is considered the material to recurse."
 190   (define (process-music queue)
 191     (if (not (null? queue))
 192         (let* ((elt (car queue))
 193                (stop (function elt)))
 194           (process-music (if (boolean? stop)
 195                              (if stop
 196                                  (cdr queue)
 197                                  (append (music-elements elt) (cdr queue)))
 198                              ((if (cheap-list? stop) append cons)
 199                               stop (cdr queue)))))))
 200   (process-music (list music)))