Issue 3411: Mostly cosmetic simplifications in woodwind diagrams and library

3 files changed, 44 insertions, 82 deletions

diff --git a/scm/define-woodwind-diagrams.scm b/scm/define-woodwind-diagrams.scm
index cffe25c07d..16a4474b7e 100644
--- a/scm/define-woodwind-diagrams.scm
+++ b/scm/define-woodwind-diagrams.scm
@@ -23,7 +23,7 @@
 
 (define-public (symbol-concatenate . names)
   "Like @code{string-concatenate}, but for symbols."
-  (string->symbol (apply string-append (map symbol->string names))))
+  (string->symbol (string-concatenate (map symbol->string names))))
 
 (define-public (function-chain arg function-list)
   "Applies a list of functions in @var{function-list} to @var{arg}.
@@ -33,34 +33,18 @@ are provided in @var{function-list}.
 
 Example: Executing @samp{(function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))}
 returns @samp{1/3}."
-  (if (null? function-list)
-      arg
-      (function-chain
-       (apply (caar function-list) (append `(,arg) (cdar function-list)))
-       (cdr function-list))))
-
-(define (rotunda-map function inlist rotunda)
-  "Like map, but with a rotating last argument to function.
-   For example:
-   @code{guile> (rotunda-map + '(1 2 3 4) '(1 -10))}
-   @code{(2 -8 4 -6)}"
-  (define (rotunda-map-chain function inlist outlist rotunda)
-    (if (null? inlist)
-        outlist
-        (rotunda-map-chain
-         function
-         (cdr inlist)
-         (append outlist (list (function (car inlist) (car rotunda))))
-         (append (cdr rotunda) (list (car rotunda))))))
-  (rotunda-map-chain function inlist '() rotunda))
+  (fold
+   (lambda (fun arg) (apply (car fun) arg (cdr fun)))
+   arg
+   function-list))
 
 (define (assoc-keys alist)
   "Gets the keys of an alist."
-  (map (lambda (x) (car x)) alist))
+  (map car alist))
 
 (define (assoc-values alist)
   "Gets the values of an alist."
-  (map (lambda (x) (cdr x)) alist))
+  (map cdr alist))
 
 (define (get-slope-offset p1 p2)
   "Gets the slope and offset for p1 and p2.
@@ -82,7 +66,7 @@ returns @samp{1/3}."
 
 (define (entry-greater-than-x? input-list x)
   "Is there an entry greater than @code{x} in @code{input-list}?"
-  (any (lambda (y) (> y x)) input-list))
+  (member x input-list <))
 
 (define (n-true-entries input-list)
   "Returns number of true entries in @code{input-list}."
@@ -120,7 +104,7 @@ returns @samp{1/3}."
 
 ;; Color a stencil gray
 (define (gray-colorize stencil)
-  (apply ly:stencil-in-color (cons stencil (x11-color 'grey))))
+  (apply ly:stencil-in-color stencil (x11-color 'grey)))
 
 ;; A connected path stencil that is surrounded by proc
 (define (rich-path-stencil ls x-stretch y-stretch proc)
@@ -208,38 +192,32 @@ returns @samp{1/3}."
 ;; Otherwise, there can be various levels of "closure" on the holes
 ;; ring? allows for a ring around the holes as well
 (define (make-symbol-alist symbol simple? ring?)
-  (filter (lambda (x)
-            (not
-             (equal?
-              x
-              `(,(symbol-concatenate symbol 'T 'F) .
-                ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))))
-          (append
-           `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
-             (,(symbol-concatenate symbol 'T) .
-              ,(expt (assoc-get 'F HOLE-FILL-LIST) 2)))
-           (if simple?
-               '()
-               (apply append
-                      (map (lambda (x)
-                             (append
-                              `((,(symbol-concatenate symbol (car x) 'T)
-                                 . ,(expt (cdr x) 2))
-                                (,(symbol-concatenate symbol 'T (car x))
-                                 . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
-                                (,(symbol-concatenate symbol (car x))
-                                 . ,(cdr x)))
-                              (apply append
-                                     (map (lambda (y)
-                                            (map (lambda (a b)
-                                                   `(,(symbol-concatenate symbol
-                                                                          (car a)
-                                                                          'T
-                                                                          (car b))
-                                                     . ,(* (cdr a) (cdr b))))
-                                                 `(,x ,y) `(,y ,x)))
-                                          (cdr (member x HOLE-FILL-LIST))))))
-                           (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST))))))))
+  (delete `(,(symbol-concatenate symbol 'T 'F) .
+            ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))
+          `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST))
+            (,(symbol-concatenate symbol 'T) .
+             ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))
+            ,@(if simple?
+                  '()
+                  (append-map
+                   (lambda (x)
+                     `((,(symbol-concatenate symbol (car x) 'T)
+                        . ,(expt (cdr x) 2))
+                       (,(symbol-concatenate symbol 'T (car x))
+                        . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST)))
+                       (,(symbol-concatenate symbol (car x))
+                        . ,(cdr x))
+                       ,@(append-map
+                          (lambda (y)
+                            (map (lambda (a b)
+                                   `(,(symbol-concatenate symbol
+                                                          (car a)
+                                                          'T
+                                                          (car b))
+                                     . ,(* (cdr a) (cdr b))))
+                                 `(,x ,y) `(,y ,x)))
+                          (cdr (member x HOLE-FILL-LIST)))))
+                   (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST)))))))
 
 ;;; Commands for text layout
 
@@ -1188,10 +1166,10 @@ returns @samp{1/3}."
      (append
       (map
        (lambda (l)
-         (rotunda-map
+         (map
           -
           l
-          (list-tail first-bezier 6)))
+          (apply circular-list (list-tail first-bezier 6))))
        (make-tilted-portion
         first-bezier
         second-bezier
diff --git a/scm/display-woodwind-diagrams.scm b/scm/display-woodwind-diagrams.scm
index c5eeaefbb3..f1190f13c6 100644
--- a/scm/display-woodwind-diagrams.scm
+++ b/scm/display-woodwind-diagrams.scm
@@ -1671,7 +1671,7 @@
         `(((,(caaar possibility-list) .
             ,(assoc-get input-key (cdar possibility-list))) .
             ,(assoc-get (caar possibility-list) canonic-list)))
-        (assoc-remove (caar possibility-list) canonic-list))
+        (alist-delete (caar possibility-list) canonic-list))
        (update-possb-list input-key (cdr possibility-list) canonic-list))))
 
 (define (key-crawler input-list possibility-list)
diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 94a566ead4..22e5b67302 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -453,17 +453,6 @@ bookoutput function"
             (cons (cdar alist)
                   (flatten-alist (cdr alist))))))
 
-(define (assoc-remove key alist)
-  "Remove key (and its corresponding value) from an alist.
-   Different than assoc-remove! because it is non-destructive."
-  (define (assoc-crawler key l r)
-    (if (null? r)
-        l
-        (if (equal? (caar r) key)
-            (append l (cdr r))
-            (assoc-crawler key (append l `(,(car r))) (cdr r)))))
-  (assoc-crawler key '() alist))
-
 (define-public (map-selected-alist-keys function keys alist)
   "Return @var{alist} with @var{function} applied to all of the values
 in list @var{keys}.
@@ -473,19 +462,14 @@ For example:
 @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
 @code{((a . -1) (b . 2) (c . 3) (d . 4)}
 @end example"
-  (define (map-selected-alist-keys-helper function key alist)
+  (define (map-selected-alist-keys-helper key alist)
     (map
      (lambda (pair)
        (if (equal? key (car pair))
            (cons key (function (cdr pair)))
            pair))
      alist))
-  (if (null? keys)
-      alist
-      (map-selected-alist-keys
-       function
-       (cdr keys)
-       (map-selected-alist-keys-helper function (car keys) alist))))
+  (fold map-selected-alist-keys-helper alist keys))
 
 ;;;;;;;;;;;;;;;;
 ;; vector
@@ -558,10 +542,10 @@ For example:
 
 (define-public (flatten-list x)
   "Unnest list."
-  (cond ((null? x) '())
-        ((not (pair? x)) (list x))
-        (else (append (flatten-list (car x))
-                      (flatten-list (cdr x))))))
+  (let loop ((x x) (tail '()))
+    (cond ((list? x) (fold-right loop tail x))
+          ((not (pair? x)) (cons x tail))
+          (else (loop (car x) (loop (cdr x) tail))))))
 
 (define (list-minus a b)
   "Return list of elements in A that are not in B."