[PATCH] Issues 714 and 404: Add greater user flexibility in naming output files using output-suffix. output name handling now moved to its own procedure in lily-library.scm Amended to use ly:get-assoc to pick up initial value of parser variable output-count and remove redundant check on initial call. Removed regexp call which wasn't working anyway - Western European unaccented characters now supported in output-suffix.

[Ian Hulin <ian@xxxxxxxxxxxx>]

Signed-off-by: Ian Hulin <ian@xxxxxxxxxxxx>
---
 scm/lily-library.scm |  158 ++++++++++++++++++++++++++++----------------------
 1 files changed, 89 insertions(+), 69 deletions(-)

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index e7f1d29..d5bd1e2 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -6,9 +6,6 @@
 ;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@xxxxxxx>
 ;;;; Han-Wen Nienhuys <hanwen@xxxxxxxxx>
 
-; for take, drop, take-while, list-index, and find-tail:
-(use-modules (srfi srfi-1))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; constants.
 
@@ -134,27 +131,43 @@
 
   (ly:make-score music))
 
+(define (get-outfile-name parser base)
+(let*
+    ((output-suffix (ly:parser-lookup parser 'output-suffix))
+     (counter-alist (ly:parser-lookup parser 'counter-alist))
+     (output-count (assoc-get output-suffix counter-alist 0))
+     (result base ) )
+    ;; Allow all ASCII alphanumerics,
+    ;;   including accents
+    ;; FIXME 
+    ;; eight-bit accented chars like C caron will be passed through 
+    ;; and will crash the ghostscript backend. 
+    ;; Previous regexp using pattern "[^A-Za-z0-9-]" didn't work and 
+    ;; can't get this one to fly, either
+    
+    ;(if (string? output-suffix)
+    ;(set! result (format "~a-~a" base (string-regexp-substitute
+    ;					   "[^[:alnum:]-]" "_" output-suffix))))
+    (if (string? output-suffix)
+	(set! result (format "~a-~a" base output-suffix)))
+
+
+    ;; assoc-get call will always have returned a number
+    (if (> output-count 0)
+	(set! result (format #f "~a-~a" result output-count)))
+    
+    (ly:parser-define!
+	  parser 'counter-alist (assoc-set! counter-alist output-suffix  (1+ output-count)))
+    result ) )
+
 (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))
-       (output-suffix (ly:parser-lookup parser 'output-suffix)) )
+       (outfile-name (get-outfile-name parser base)) )
 
-    (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))
-    (process-procedure book paper layout base)
-    ))
+      (process-procedure book paper layout outfile-name)  ) )
 
 (define-public (print-book-with-defaults parser book)
   (print-book-with parser book ly:book-process))
@@ -341,29 +354,53 @@ found."
 		   (cons x acc))))
 	 '() lst) '()))
 
-(define (split-at-predicate pred lst)
-  "Split LST into two lists at the first element that returns #f for
-  (PRED previous_element element). Return the two parts as a pair.
-  Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
-  (if (null? lst)
-      (list lst)
-      (let ((i (list-index pred (cdr lst) lst)))
-        (if i
-            (cons (take lst (1+ i)) (drop lst (1+ i)))
-            (list lst)))))
-
-(define-public (split-list-by-separator lst pred)
-  "Split LST at each element that satisfies PRED, and return the parts
-  (with the separators removed) as a list of lists. Example:
-  (split-list-by-separator '(a 0 b c 1 d) number?) ==> ((a) (b c) (d))"
-  (let loop ((result '()) (lst lst))
-    (if (and lst (not (null? lst)))
-        (loop
-          (append result
-                  (list (take-while (lambda (x) (not (pred x))) lst)))
-          (let ((tail (find-tail pred lst)))
-            (if tail (cdr tail) #f)))
-       result)))
+(define (split-at-predicate predicate lst)
+ "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
+  into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) 
+  Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
+  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)
+   (cond
+    ((null? lst) acc)
+    ((null? (cdr lst))
+     (set-car! acc (cons (car lst) (car acc)))
+     acc)
+    ((predicate (car lst) (cadr lst))
+     (set-car! acc (cons (car lst) (car acc)))
+     (inner-split predicate (cdr lst) acc))
+    (else
+     (set-car! acc (cons (car lst) (car acc)))
+     (set-cdr! acc (cdr lst))
+     acc)))
+ 
+ (let* ((c (cons '() '())))
+   (inner-split predicate lst  c)
+   (set-car! c (reverse! (car c)))
+   c))
+
+(define-public (split-list-by-separator lst sep?)
+   "(display (split-list-by-separator '(a b c / d e f / g) (lambda (x) (equal? x '/))))
+   =>
+   ((a b c) (d e f) (g))
+  "
+   ;; " Emacs is broken
+   (define (split-one sep?  lst acc)
+     "Split off the first parts before separator and return both parts."
+     (if (null? lst)
+	 (cons acc '())
+	 (if (sep? (car lst))
+	     (cons acc (cdr lst))
+	     (split-one sep? (cdr lst) (cons (car lst) acc)))))
+   
+   (if (null? lst)
+       '()
+       (let* ((c (split-one sep? lst '())))
+	 (cons (reverse! (car c) '()) (split-list-by-separator (cdr c) sep?)))))
 
 (define-public (offset-add a b)
   (cons (+ (car a) (car b))
@@ -555,27 +592,12 @@ possibly turned off."
    (reverse matches))
 
 ;;;;;;;;;;;;;;;;
-;; other
-
+; other
 (define (sign x)
   (if (= x 0)
       0
       (if (< x 0) -1 1)))
 
-(define-public (binary-search start end getter target-val)
-  (_i "Find the index between @var{start} and @var{end} (an integer)
-which will produce the closest match to @var{target-val} when
-applied to function @var{getter}.")
-  (if (<= end start)
-      start
-      (let* ((compare (quotient (+ start end) 2))
-	     (get-val (getter compare)))
-	(cond
-	 ((< target-val get-val)
-	  (set! end (1- compare)))
-	 ((< get-val target-val)
-	  (set! start (1+ compare))))
-	(binary-search start end getter target-val))))
 
 (define-public (car< a b)
   (< (car a) (car b)))
@@ -618,19 +640,17 @@ applied to function @var{getter}.")
 
 ;;; FONT may be font smob, or pango font string...
 (define-public (font-name-style font)
-  ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
-  (if (and (string? font)
-	   (string-prefix? "feta-alphabet" font))
-      (string-append "emmentaler"
-		     "-"
-		     (substring font
-				(string-length "feta-alphabet")
-				(string-length font)))
+      ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
       (let* ((font-name (ly:font-name font))
-	     (full-name (if font-name font-name (ly:font-file-name font))))
-	(if (string-prefix? "Aybabtu" full-name)
-	    "aybabtu"
-	    (string-downcase full-name)))))
+	     (full-name (if font-name font-name (ly:font-file-name font)))
+	     (name-style (string-split full-name #\-)))
+	;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
+	(if (string-prefix? "feta-alphabet" full-name)
+	    (list "emmentaler"
+		  (substring  full-name (string-length "feta-alphabet")))
+	    (if (not (null? (cdr name-style)))
+	    name-style
+	    (append name-style '("Regular"))))))
 
 (define-public (modified-font-metric-font-scaling font)
   (let* ((designsize (ly:font-design-size font))
-- 
1.6.0.4


--------------080809050108030401030305
Content-Type: text/plain;
 name="Test-output-suffix.ly"
Content-Disposition: inline;
 filename="Test-output-suffix.ly"
Content-Transfer-Encoding: base64

XHZlcnNpb24gIjIuMTIuMSIKXGhlYWRlciB7CiAgdGl0bGUgPSAiRXhzdWx0YXRlLCBKdWJp
bGF0ZSIKICBzdWJ0aXRsZSA9ICJNb3RldCIKICBzdWJzdWJ0aXRsZSA9ICJLLiAxNjUiCiAg
aW5zdHJ1bWVudCA9ICJTb3ByYW5vIFNvbG8gYW5kIE9yY2hlc3RyYSIKICBjb21wb3NlciA9
ICJXLiBBLiBNb3phcnQiCiAgb3B1cyA9ICJLViAxNjUiCn0KbW92b25lc2V0dGluZ3MgPSB7
CiBca2V5IGYgXG1ham9yCiBcdGltZSA0LzQKIFx0ZW1wbyAiQWxsZWdybyIgND0xMjgKICAg
CiB9Cm1vdnR3b3NldHRpbmdzID0gewogXGtleSBhIFxtYWpvcgogXHRpbWUgMy80CiBcdGVt
cG8gIkFuZGFudGUiIDQ9NzIKIH0gCkJDbW92b25lTXVzaWMgPSBccmVsYXRpdmUgYyB7CiAg
XG1vdm9uZXNldHRpbmdzCiAgXGNsZWYgYmFzcyBmOCBmIGYgZiBmIGYgZiBmIHwKfSAKQkNt
b3Z0d29NdXNpYyA9IFxyZWxhdGl2ZSBjIHsKXG1vdnR3b3NldHRpbmdzCiAgXGNsZWYgYmFz
cwogIFxwYXJ0aWFsIDggcjgKICByNCBhJzQgYSwgfAp9CiUjKGRlZmluZSBvdXRwdXQtc3Vm
Zml4ICLEjGHEjWEtQWxsZWdybyIpICVUaGlzIGZhaWxzIHdpdGggY3VycmVudCBjb2RlCiMo
ZGVmaW5lIG91dHB1dC1zdWZmaXggIlNjaGxvw58tQWxsZWdybyIpClxib29rIHsKXGhlYWRl
ciB7CgkJc3VidGl0bGUgPSAiUHJlbWnDqHJlLUFsbGVncm8iCgl9ClxzY29yZSB7CgkKCVxC
Q21vdm9uZU11c2ljCn0KfQojKGRlZmluZSBvdXRwdXQtc3VmZml4ICJGbMO2dGVuLUFuZGFu
dGUiKSAKXGJvb2sgewpcaGVhZGVyIHsKCXN1YnRpdGxlID0gIklJLiBBbmRhbnRlIgp9Clxz
Y29yZSB7CglcQkNtb3Z0d29NdXNpYwp9Cn0KCg==
--------------080809050108030401030305--

---

----
Join the Frogs!