scm/song-util.scm

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