X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=8176db1d7b66ee31ec1ebd4f881709e662cc8545;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=fc8d291dec662e041b4513336aaea10b94934230;hpb=f3487cef38f45d65137225ece9f5c289569138bd;p=lilypond.git diff --git a/scm/lily-library.scm b/scm/lily-library.scm index fc8d291dec..8176db1d7b 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -3,9 +3,11 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2006 Jan Nieuwenhuizen +;;;; (c) 1998--2008 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants. (define-public X 0) (define-public Y 1) @@ -17,57 +19,107 @@ (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 (define-public ZERO-MOMENT (ly:make-moment 0 1)) (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))) @@ -75,51 +127,37 @@ (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))) - - (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) - )) + (base (ly:parser-output-name parser)) + (output-suffix (ly:parser-lookup parser 'output-suffix)) ) -(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 + (define-public assoc-get ly:assoc-get) (define-public (uniqued-alist alist acc) @@ -132,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." @@ -192,6 +222,7 @@ found." ;;;;;;;;;;;;;;;; ;; vector + (define-public (vector-for-each proc vec) (do ((i 0 (1+ i))) @@ -201,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) @@ -269,6 +285,7 @@ found." (define-public (count-list lst) "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... ) " + (define (helper l acc count) (if (pair? l) (helper (cdr l) (cons (cons (car l) count) acc) (1+ count)) @@ -305,19 +322,17 @@ found." "Return list of elements in A that are not in B." (lset-difference eq? a b)) -;; TODO: use the srfi-1 partition function. (define-public (uniq-list lst) - - "Uniq LST, assuming that it is sorted" - (define (helper acc lst) - (if (null? lst) - acc - (if (null? (cdr lst)) - (cons (car lst) acc) - (if (equal? (car lst) (cadr lst)) - (helper acc (cdr lst)) - (helper (cons (car lst) acc) (cdr lst)))))) - (reverse! (helper '() lst) '())) + "Uniq LST, assuming that it is sorted. Uses equal? for comparisons." + + (reverse! + (fold (lambda (x acc) + (if (null? acc) + (list x) + (if (equal? x (car acc)) + acc + (cons x acc)))) + '() lst) '())) (define (split-at-predicate predicate lst) "Split LST = (a_1 a_2 ... a_k b_1 ... b_k) @@ -326,6 +341,7 @@ found." L1 is copied, L2 not. (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))" + ;; " Emacs is broken (define (inner-split predicate lst acc) @@ -408,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)" @@ -451,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") @@ -462,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)) @@ -482,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, @@ -544,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))) @@ -599,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")))