X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=8176db1d7b66ee31ec1ebd4f881709e662cc8545;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=0d09beae53b5c6f9e994c10cbc5dbe0cd192eb47;hpb=8dfabc02615ad25d5450cb5f42e194ce50a7be18;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 0d09beae53..8176db1d7b 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -3,7 +3,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2006 Jan Nieuwenhuizen +;;;; (c) 1998--2008 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -19,16 +19,27 @@ (define-public DOWN -1) (define-public CENTER 0) -(define-safe-public DOUBLE-FLAT -4) -(define-safe-public THREE-Q-FLAT -3) -(define-safe-public FLAT -2) -(define-safe-public SEMI-FLAT -1) +(define-safe-public DOUBLE-FLAT-QTS -4) +(define-safe-public THREE-Q-FLAT-QTS -3) +(define-safe-public FLAT-QTS -2) +(define-safe-public SEMI-FLAT-QTS -1) +(define-safe-public NATURAL-QTS 0) +(define-safe-public SEMI-SHARP-QTS 1) +(define-safe-public SHARP-QTS 2) +(define-safe-public THREE-Q-SHARP-QTS 3) +(define-safe-public DOUBLE-SHARP-QTS 4) +(define-safe-public SEMI-TONE-QTS 2) + +(define-safe-public DOUBLE-FLAT -1) +(define-safe-public THREE-Q-FLAT -3/4) +(define-safe-public FLAT -1/2) +(define-safe-public SEMI-FLAT -1/4) (define-safe-public NATURAL 0) -(define-safe-public SEMI-SHARP 1) -(define-safe-public SHARP 2) -(define-safe-public THREE-Q-SHARP 3) -(define-safe-public DOUBLE-SHARP 4) -(define-safe-public SEMI-TONE 2) +(define-safe-public SEMI-SHARP 1/4) +(define-safe-public SHARP 1/2) +(define-safe-public THREE-Q-SHARP 3/4) +(define-safe-public DOUBLE-SHARP 1) +(define-safe-public SEMI-TONE 1/2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; moments @@ -38,44 +49,77 @@ (define-public (moment-min a b) (if (ly:moment output hooks. +(define-public (collect-bookpart-for-book parser book-part) + "Toplevel book-part handler" + (define (add-bookpart book-part) + (ly:parser-define! + parser 'toplevel-bookparts + (cons book-part (ly:parser-lookup parser 'toplevel-bookparts)))) + ;; If toplevel scores have been found before this \bookpart, + ;; add them first to a dedicated bookpart + (if (pair? (ly:parser-lookup parser 'toplevel-scores)) + (begin + (add-bookpart (ly:make-book-part + (ly:parser-lookup parser 'toplevel-scores))) + (ly:parser-define! parser 'toplevel-scores (list)))) + (add-bookpart book-part)) + (define-public (collect-scores-for-book parser score) (ly:parser-define! parser 'toplevel-scores (cons score (ly:parser-lookup parser 'toplevel-scores)))) +(define-public (collect-music-aux score-handler parser music) + (define (music-property symbol) + (let ((value (ly:music-property music symbol))) + (if (not (null? value)) + value + #f))) + (cond ((music-property 'page-marker) + ;; a page marker: set page break/turn permissions or label + (begin + (let ((label (music-property 'page-label))) + (if (symbol? label) + (score-handler (ly:make-page-label-marker label)))) + (for-each (lambda (symbol) + (let ((permission (music-property symbol))) + (if (symbol? permission) + (score-handler + (ly:make-page-permission-marker symbol + (if (eqv? 'forbid permission) + '() + permission)))))) + (list 'line-break-permission 'page-break-permission + 'page-turn-permission)))) + ((not (music-property 'void)) + ;; a regular music expression: make a score with this music + ;; void music is discarded + (score-handler (scorify-music music parser))))) + +(define-public (collect-music-for-book parser music) + "Top-level music handler" + (collect-music-aux (lambda (score) + (collect-scores-for-book parser score)) + parser + music)) + +(define-public (collect-book-music-for-book parser book music) + "Book music handler" + (collect-music-aux (lambda (score) + (ly:book-add-score! book score)) + parser + music)) (define-public (scorify-music music parser) + "Preprocess MUSIC." (for-each (lambda (func) (set! music (func music parser))) @@ -83,48 +127,33 @@ (ly:make-score music)) -(define-public (collect-music-for-book parser music) - ;; discard music if its 'void property is true. - (let ((void-music (ly:music-property music 'void))) - (if (or (null? void-music) (not void-music)) - (collect-scores-for-book parser (scorify-music music parser))))) - - -(define-public (print-book-with-defaults parser book) +(define (print-book-with parser book process-procedure) (let* ((paper (ly:parser-lookup parser '$defaultpaper)) (layout (ly:parser-lookup parser '$defaultlayout)) (count (ly:parser-lookup parser 'output-count)) - (base (ly:parser-output-name parser))) + (base (ly:parser-output-name parser)) + (output-suffix (ly:parser-lookup parser 'output-suffix)) ) - (if (not (integer? count)) - (set! count 0)) - - (if (> count 0) - (set! base (format #f "~a-~a" base count))) - - (ly:parser-define! parser 'output-count (1+ count)) - (ly:book-process book paper layout base) - )) - -(define-public (print-score-with-defaults parser score) - (let* - ((paper (ly:parser-lookup parser '$defaultpaper)) - (layout (ly:parser-lookup parser '$defaultlayout)) - (header (ly:parser-lookup parser '$defaultheader)) - (count (ly:parser-lookup parser 'output-count)) - (base (ly:parser-output-name parser))) + (if (string? output-suffix) + (set! base (format "~a-~a" base (string-regexp-substitute + "[^a-zA-Z0-9-]" "_" output-suffix)))) + ;; must be careful: output-count is under user control. (if (not (integer? count)) (set! count 0)) (if (> count 0) (set! base (format #f "~a-~a" base count))) - (ly:parser-define! parser 'output-count (1+ count)) - (ly:score-process score header paper layout base) + (process-procedure book paper layout base) )) +(define-public (print-book-with-defaults parser book) + (print-book-with parser book ly:book-process)) + +(define-public (print-book-with-defaults-as-systems parser book) + (print-book-with parser book ly:book-process-to-systems)) ;;;;;;;;;;;;;;;; ;; alist @@ -141,14 +170,6 @@ (stringstring (car x)) (symbol->string (car y)))) -(define-public (chain-assoc x alist-list) - (if (null? alist-list) - #f - (let* ((handle (assoc x (car alist-list)))) - (if (pair? handle) - handle - (chain-assoc x (cdr alist-list)))))) - (define-public (chain-assoc-get x alist-list . default) "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not found." @@ -211,24 +232,9 @@ found." ;;;;;;;;;;;;;;;; ;; hash -(if (not (defined? 'hash-table?)) ;; guile 1.6 compat - (begin - (define hash-table? vector?) - (define-public (hash-for-each proc tab) - (hash-fold (lambda (k v prior) - (proc k v) - #f) - #f - tab)) - (define-public (hash-table->alist t) - "Convert table t to list" - (apply append (vector->list t)))) - - ;; native hashtabs. - (begin - (define-public (hash-table->alist t) - (hash-fold (lambda (k v acc) (acons k v acc)) - '() t)))) +(define-public (hash-table->alist t) + (hash-fold (lambda (k v acc) (acons k v acc)) + '() t)) ;; todo: code dup with C++. (define-safe-public (alist->hash-table lst) @@ -317,13 +323,13 @@ found." (lset-difference eq? a b)) (define-public (uniq-list lst) - "Uniq LST, assuming that it is sorted" + "Uniq LST, assuming that it is sorted. Uses equal? for comparisons." (reverse! (fold (lambda (x acc) (if (null? acc) (list x) - (if (eq? x (car acc)) + (if (equal? x (car acc)) acc (cons x acc)))) '() lst) '())) @@ -418,6 +424,9 @@ found." (define-public interval-end cdr) +(define-public (interval-bound interval dir) + ((if (= dir RIGHT) cdr car) interval)) + (define-public (interval-index interval dir) "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)" @@ -461,9 +470,16 @@ found." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; - - +;; string + +(define-public (string-endswith s suffix) + (equal? suffix (substring s + (max 0 (- (string-length s) (string-length suffix))) + (string-length s)))) + +(define-public (string-startswith s prefix) + (equal? prefix (substring s 0 (min (string-length s) (string-length prefix))))) + (define-public (string-encode-integer i) (cond ((= i 0) "o") @@ -472,9 +488,6 @@ found." (make-string 1 (integer->char (+ 65 (modulo i 26)))) (string-encode-integer (quotient i 26)))))) -(define-public (ly:numbers->string lst) - (string-join (map ly:number->string lst) " ")) - (define (number->octal-string x) (let* ((n (inexact->exact x)) (n64 (quotient n 64)) @@ -492,6 +505,11 @@ found." (string-append (ly:number->string (car c)) " " (ly:number->string (cdr c)))) +(define-public (dir-basename file . rest) + "Strip suffixes in REST, but leave directory component for FILE." + (define (inverse-basename x y) (basename y x)) + (simple-format #f "~a/~a" (dirname file) + (fold inverse-basename file rest))) (define-public (write-me message x) "Return X. Display MESSAGE and write X. Handy for debugging, @@ -554,7 +572,9 @@ possibly turned off." 0 (if (< x 0) -1 1))) -(define-public (car< a b) (< (car a) (car b))) + +(define-public (car< a b) + (< (car a) (car b))) (define-public (symbolstring lst) (symbol->string r))) @@ -609,14 +629,16 @@ possibly turned off." (define-public (version-not-seen-message input-file-name) (ly:message - (string-append - input-file-name ": 0: " (_ "warning: ") - (format #f - (_ "no \\version statement found, please add~afor future compatibility") - (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))) + "~a:0: ~a: ~a" + input-file-name + (_ "warning: ") + (format #f + (_ "no \\version statement found, please add~afor future compatibility") + (format #f "\n\n\\version ~s\n\n" (lilypond-version))))) (define-public (old-relative-not-used-message input-file-name) (ly:message - (string-append - input-file-name ": 0: " (_ "warning: ") - (_ "old relative compatibility not used")))) + "~a:0: ~a: ~a" + input-file-name + (_ "warning: ") + (_ "old relative compatibility not used")))