;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 2010--2012 Mike Solomon <mikesol@stanfordalumni.org>
+;;;; Copyright (C) 2010--2015 Mike Solomon <mikesol@stanfordalumni.org>
;;;; Clarinet drawings copied from diagrams created by
;;;; Gilles Thibault <gilles.thibault@free.fr>
;;;;
(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}.
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.
(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}."
;; 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)
;; 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
(flatten-list
(map (lambda (x)
(coord-translate
- (coord-rotate x (atan (/ y (* 2 0.25))))
+ (coord-rotated x (cons y (* 2 0.25)))
'(1.0 . 0)))
l)))
`(((0 . ,y) (,x . ,y) (,x . 0))
(map (lambda (l)
(flatten-list
(map (lambda (x)
- (coord-rotate x (atan (/ y (* 2 0.25)))))
+ (coord-rotated x (cons y (* 2 0.25))))
l)))
`(,(list-tail up-part 1)
,(list-head down-part 1)
(define saxophone-rh-high-fis-key-stencil
(standard-path-stencil
- (append
- '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
- (map (lambda (l)
- (flatten-list
- (map (lambda (x)
- (coord-rotate x (atan (* -1 (/ PI 6)))))
- l)))
- '(((0.6 . -1.0))
- ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
- ((0.0 . 0.0)))))
+ (let* ((angle -30)
+ (dir2 (ly:directed (* -0.5 angle)))
+ ;; This comparatively awful expression calculates how far
+ ;; along the tangents opened by 'angle' with a radius of 0.6
+ ;; the control points need to move in order to have the
+ ;; middle of the bezier curve exactly on radius.
+ (out (* 0.6 (coord-y dir2) (- 4/3 (* 1/3 (coord-x dir2))))))
+ (append
+ '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0))
+ `((0.6 ,(- out)
+ ,@(flatten-list (map (lambda (x) (coord-rotated x angle))
+ `((0.6 . ,out)
+ (0.6 . 0.0))))))
+ (map (lambda (l)
+ (flatten-list
+ (map (lambda (x)
+ (coord-rotated x angle))
+ l)))
+ '(((0.6 . -1.0))
+ ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0))
+ ((0.0 . 0.0))))))
0.75
0.75))
(*
(car slope-offset1)
(+ keylen (list-ref first-bezier 6))) (cdr slope-offset1))))
- ((if bezier? (lambda (x) `(,(apply append x))) identity)
+ ((if bezier? (lambda (x) `(,(concatenate x))) identity)
`((,(+ (+ keylen 1.75) (list-ref first-bezier 6))
,(+
(*
(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