lib/90-makescore.scm

   1 ;------------------------------------------------------------------;
   2 ; opus_libre -- 90-makescore.scm                                   ;
   3 ;                                                                  ;
   4 ; (c) 2008-2011 Valentin Villenave <valentin@villenave.net>        ;
   5 ;                                                                  ;
   6 ;     opus_libre is a free framework for GNU LilyPond: you may     ;
   7 ; redistribute it and/or modify it under the terms of the GNU      ;
   8 ; General Public License as published by the Free Software         ;
   9 ; Foundation, either version 3 of the License, or (at your option) ;
  10 ; any later version.                                               ;
  11 ;     This program is distributed WITHOUT ANY WARRANTY; without    ;
  12 ; even the implied warranty of MERCHANTABILITY or FITNESS FOR A    ;
  13 ; PARTICULAR PURPOSE.  You should have received a copy of the GNU  ;
  14 ; General Public License along with this program (typically in the ;
  15 ; share/doc/ directory).  If not, see http://www.gnu.org/licenses/ ;
  16 ;                                                                  ;
  17 ;------------------------------------------------------------------;
  18
  19
  20 (define numbers #f)
  21 (define conf:structure numbers)
  22 (define *pagebreak-after* (make-parameter #f))
  23 (define *pagebreak-before* (make-parameter #f))
  24
  25 ; This is admittedly ugly.
  26 (define pagebreak
  27   (make-music 'EventChord 'elements
  28     '((make-music 'LineBreakEvent 'break-permission 'force)
  29       (make-music 'PageBreakEvent 'break-permission 'force))
  30     'page-break-permission 'force
  31     'line-break-permission 'force
  32     'page-marker #t))
  33
  34 (define (alist-reverse alist)
  35   "Browse ALIST by looking for props, not by keys."
  36   (if (null? alist) '()
  37       (cons (cons (cdar alist) (caar alist))
  38             (alist-reverse (cdr alist)))))
  39
  40
  41 (define (ls-index str lst)
  42   "Where is STR in LST?"
  43   (- (length lst) (length (member str lst))))
  44
  45 (define (eval-skel file)
  46   "Load skeleton in FILE, and apply it to the
  47 current-part music."
  48   (eval-string (format #f
  49                        "(define-public (apply-skel arg instr-list)
  50       (*current-part* (car arg))
  51       (let* ((str (cdr arg))
  52              (key (assoc-ref (alist-reverse instr-list) str)))
  53         (if (string? key) #{ \\newStaff $key #}
  54             (begin
  55               (if (not (or (string=? \"\" str) (string=? lang:all)))
  56                   (ly:debug-message \"Unknown instrument variable;
  57   ---> please check your `make' argument.\"))
  58                  #{ ~a #}))))"
  59                        (read-file (open-input-file file)))))
  60
  61 (define output-redirect
  62 ;;   "Make sure that the PDF output will be placed in
  63 ;; the output-dir directory.  If book-filename has already
  64 ;; been defined by the user, just keep it, otherwise it
  65 ;; will be named after the score directory's name in scores/."
  66   (let* ((orig-filename (if (defined-string? 'output-filename)
  67                             output-filename
  68                             (ly:parser-output-name)))
  69          (prefix (if (defined-string? 'conf:output-dir)
  70                      (string-append conf:output-dir "/")
  71                      #f))
  72          (suffix (if (eq? (ly:get-option 'backend) 'ps)
  73                      ".pdf"
  74                      #f))
  75          (new-filename (car (reverse (string-split (*current-score*) #\/))))
  76          (new-filepath (string-append prefix new-filename))
  77          (main-filepath (string-append conf:main-file suffix))
  78          (long-filepath (string-append new-filepath suffix))
  79          (main-symlink (if (access? main-filepath 0)
  80                            (readlink main-filepath)
  81                            #f)))
  82     (if suffix
  83         (if (and main-symlink (string=? main-symlink long-filepath))
  84             (ly:debug
  85              "Output file ~a already points to ~a, not making a new symlink."
  86              main-filepath
  87              long-filepath)
  88             (begin
  89              (if main-symlink (delete-file main-filepath))
  90              (symlink long-filepath main-filepath))))
  91     (set! output-filename
  92           (if (not prefix)
  93               orig-filename
  94               new-filepath))))
  95
  96 (define make
  97 ;;   "This is where the score is put together and all functions
  98 ;; are evaluated.  \make takes a string argument, that can be either:
  99 ;;   - the name of an instrument (to compile just a separate part)
 100 ;;   - the name of a section, or a separate piece
 101 ;;   - the name of a specific skeleton.
 102 ;; If ARG is an empty string or #"all" (or a localized equivalent),
 103 ;; then the whole score will be built.
 104 ;; Unrecognized string arguments are tolerated for now, but not recommended."
 105   (define-music-function (arg) (string?)
 106     eval-conf
 107     eval-lang
 108     eval-macros
 109     eval-layout
 110     eval-theme
 111     (let* ((defined-structure (ly:parser-lookup 'structure))
 112            (struct (cond ((not defined-structure) conf:default-structure)
 113                          ((string? defined-structure) (list defined-structure))
 114                          ((list? defined-structure) defined-structure))))
 115       (if (string? (member arg struct))
 116           (set! struct arg))
 117
 118       (map (lambda (part)
 119          (if (string-suffix? "|" part)
 120              (let* ((num (ls-index part struct))
 121                     (trimmed (string-drop-right part 1)))
 122                (*pagebreak-after* #t)
 123                (set! part trimmed)
 124                (list-set! struct num trimmed)))
 125          (if (string-prefix? "|" part)
 126              (let* ((num (ls-index part struct))
 127                     (trimmed (string-drop part 1)))
 128                (*pagebreak-before* #t)
 129                (set! part trimmed)
 130                (list-set! struct num trimmed)))
 131          (if (string-suffix? (or ".ly" ".ily") part)
 132              (let* ((regx (string-append "/" part "$"))
 133                     (file (car (find-files (*current-score*) regx))))
 134                 (ly:parser-include-string (format #f "\\include \"~a\"" file)))
 135              (let* ((skel-name (skel-file arg))
 136                     (skel-part (find-skel (string-append skel-name "-" part)))
 137                     (skel-num (find-skel (string-append skel-name "-" (number->string (ls-index part struct))))))
 138                (if (string? skel-part) (eval-skel skel-part)
 139                    (if (string? skel-num) (eval-skel skel-num)
 140                        (eval-skel (find-skel (skel-file skel-name)))))
 141
 142                (let* ((music (apply-skel (cons part arg) lang:instruments))
 143                       (score (scorify-music music))
 144                       (local-layout (make-this-layout part lang:layout))
 145                       (layout $defaultlayout)
 146                       (header (make-module))
 147                       (title (make-this-text part lang:title-suffix))
 148                       (subtitle (make-this-text part lang:subtitle-suffix))
 149                       (author (make-this-text part lang:author-suffix lang:untaint-disclaimer)))
 150
 151                  (module-define! header 'piece title)
 152                  (module-define! header 'piece-subtitle subtitle)
 153                  (module-define! header 'author author)
 154                  (ly:score-set-header! score header)
 155                  (ly:score-add-output-def! score (if local-layout local-layout layout))
 156                  (if (*pagebreak-before*) (add-music pagebreak))
 157                  (add-score score)
 158                  (if (*pagebreak-after*) (add-music pagebreak))
 159                  (*has-timeline* #f)
 160                  (*pagebreak-before* #f)
 161                  (*pagebreak-after* #f)
 162                  (*untainted* #f)
 163                  output-redirect))))
 164
 165            struct)
 166       (make-music 'Music 'void #t))))
 167
 168 (include-ly (*current-score*))