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 true iff MUSIC's PROPERTY is equal to VALUE."
 133   (equal? (ly:music-property music property) value))
 134
 135 (define-public (music-name? music name)
 136   "Return true iff MUSIC's name is 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 true iff MUSIC is a property setter and sets or unsets PROPERTY."
 143   (and (music-name? music '(PropertySet PropertyUnset))
 144        (music-property-value? music 'symbol property)))
 145
 146 (define-public (music-has-property? music property)
 147   "Return true iff MUSIC contains PROPERTY."
 148   (not (eq? (ly:music-property music property) '())))
 149
 150 (define-public (property-value music)
 151   "Return value of a property setter MUSIC.
 152 If it unsets the property, return #f."
 153   (if (music-name? music 'PropertyUnset)
 154       #f
 155       (ly:music-property music 'value)))
 156
 157 (define-public (music-elements music)
 158   "Return list of all MUSIC's top-level children."
 159   (let ((elt (ly:music-property music 'element))
 160         (elts (ly:music-property music 'elements)))
 161     (if (not (null? elt))
 162         (cons elt elts)
 163         elts)))
 164
 165 (define-public (find-child music predicate)
 166   "Find the first node in MUSIC that satisfies PREDICATE."
 167   (define (find-child queue)
 168     (if (null? queue)
 169         #f
 170         (let ((elt (car queue)))
 171           (if (predicate elt)
 172               elt
 173               (find-child (append (music-elements elt) (cdr queue)))))))
 174   (find-child (list music)))
 175
 176 (define-public (find-child-named music name)
 177   "Return the first child in MUSIC that is named NAME."
 178   (find-child music (lambda (elt) (music-name? elt name))))
 179
 180 (define-public (process-music music function)
 181   "Process all nodes of MUSIC (including MUSIC) in the DFS order.
 182 Apply FUNCTION on each of the nodes.
 183 If FUNCTION applied on a node returns true, don't process the node's subtree."
 184   (define (process-music queue)
 185     (if (not (null? queue))
 186         (let* ((elt (car queue))
 187                (stop (function elt)))
 188           (process-music (if stop
 189                              (cdr queue)
 190                              (append (music-elements elt) (cdr queue)))))))
 191   (process-music (list music)))