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 (flatten lst)
 120   (cond
 121    ((null? lst)
 122     lst)
 123    ((pair? (car lst))
 124     (append (flatten (car lst)) (flatten (cdr lst))))
 125    (else
 126     (cons (car lst) (flatten (cdr lst))))))
 127
 128 (define-public (safe-car list)
 129   (if (null? list)
 130       #f
 131       (car list)))
 132
 133 (define-public (safe-last list)
 134   (if (null? list)
 135       #f
 136       (last list)))
 137
 138
 139 ;;; LilyPond utility functions
 140
 141
 142 (define-public (music-property-value? music property value)
 143   "Return true iff MUSIC's PROPERTY is equal to VALUE."
 144   (equal? (ly:music-property music property) value))
 145
 146 (define-public (music-name? music name)
 147   "Return true iff MUSIC's name is NAME."
 148   (if (list? name)
 149       (member (ly:music-property music 'name) name)
 150       (music-property-value? music 'name name)))
 151
 152 (define-public (music-property? music property)
 153   "Return true iff MUSIC is a property setter and sets or unsets PROPERTY."
 154   (and (music-name? music '(PropertySet PropertyUnset))
 155        (music-property-value? music 'symbol property)))
 156
 157 (define-public (music-has-property? music property)
 158   "Return true iff MUSIC contains PROPERTY."
 159   (not (eq? (ly:music-property music property) '())))
 160
 161 (define-public (property-value music)
 162   "Return value of a property setter MUSIC.
 163 If it unsets the property, return #f."
 164   (if (music-name? music 'PropertyUnset)
 165       #f
 166       (ly:music-property music 'value)))
 167
 168 (define-public (music-elements music)
 169   "Return list of all MUSIC's top-level children."
 170   (let ((elt (ly:music-property music 'element))
 171         (elts (ly:music-property music 'elements)))
 172     (if (not (null? elt))
 173         (cons elt elts)
 174         elts)))
 175
 176 (define-public (find-child music predicate)
 177   "Find the first node in MUSIC that satisfies PREDICATE."
 178   (define (find-child queue)
 179     (if (null? queue)
 180         #f
 181         (let ((elt (car queue)))
 182           (if (predicate elt)
 183               elt
 184               (find-child (append (music-elements elt) (cdr queue)))))))
 185   (find-child (list music)))
 186
 187 (define-public (find-child-named music name)
 188   "Return the first child in MUSIC that is named NAME."
 189   (find-child music (lambda (elt) (music-name? elt name))))
 190
 191 (define-public (process-music music function)
 192   "Process all nodes of MUSIC (including MUSIC) in the DFS order.
 193 Apply FUNCTION on each of the nodes.
 194 If FUNCTION applied on a node returns true, don't process the node's subtree."
 195   (define (process-music queue)
 196     (if (not (null? queue))
 197         (let* ((elt (car queue))
 198                (stop (function elt)))
 199           (process-music (if stop
 200                              (cdr queue)
 201                              (append (music-elements elt) (cdr queue)))))))
 202   (process-music (list music)))