X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-woodwind-diagrams.scm;h=409090b7a515b09e5842c22c4633ca9828bab310;hb=90e4d7057f3857da049dfda3d130017d4719bd6b;hp=cffe25c07d5f98e5dbcdeab4b78d2eaf35b37251;hpb=44dd3acc534e7a534f846810b481c3f603eaa92e;p=lilypond.git diff --git a/scm/define-woodwind-diagrams.scm b/scm/define-woodwind-diagrams.scm index cffe25c07d..409090b7a5 100644 --- a/scm/define-woodwind-diagrams.scm +++ b/scm/define-woodwind-diagrams.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2010--2012 Mike Solomon +;;;; Copyright (C) 2010--2015 Mike Solomon ;;;; Clarinet drawings copied from diagrams created by ;;;; Gilles Thibault ;;;; @@ -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 @@ -654,7 +632,7 @@ returns @samp{1/3}." (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)) @@ -666,7 +644,7 @@ returns @samp{1/3}." (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) @@ -960,16 +938,27 @@ returns @samp{1/3}." (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)) @@ -1043,7 +1032,7 @@ returns @samp{1/3}." (* (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)) ,(+ (* @@ -1188,10 +1177,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