]> git.donarmstrong.com Git - lilypond.git/blob - scm/stencil.scm
Add tweaking the ellipse around harp pedals
[lilypond.git] / scm / stencil.scm
1 ;;;; stencil.scm -- 
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
6
7 (define-public (stack-stencils axis dir padding stils)
8   "Stack stencils STILS in direction AXIS, DIR, using PADDING."
9   (cond
10    ((null? stils) empty-stencil)
11    ((null? (cdr stils)) (car stils))
12    (else (ly:stencil-combine-at-edge
13           (car stils) axis dir (stack-stencils axis dir padding (cdr stils))
14           padding))))
15
16 (define-public (stack-stencils-padding-list axis dir padding stils)
17   "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING."
18   (cond
19    ((null? stils) empty-stencil)
20    ((null? (cdr stils)) (car stils))
21    (else (ly:stencil-combine-at-edge
22           (car stils)
23           axis dir
24           (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
25           (car padding)))))
26
27 (define-public (centered-stencil stencil)
28   "Center stencil @var{stencil} in both the X and Y directions"
29   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
30
31 (define-public (stack-lines dir padding baseline stils)
32   "Stack vertically with a baseline-skip."
33   (define result empty-stencil)
34   (define last-y #f)
35   (do
36       ((last-stencil #f (car p))
37        (p stils (cdr p)))
38       
39       ((null? p))
40
41     (if (number? last-y)
42         (begin
43           (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
44                              padding
45                              (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
46                           baseline))
47                  (y (+ last-y  (* dir dy))))
48             
49                           
50             
51             (set! result
52                   (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
53             (set! last-y y)))
54         (begin
55           (set! last-y 0)
56           (set! result (car p)))))
57
58   result)
59     
60
61 (define-public (bracketify-stencil stil axis thick protusion padding)
62   "Add brackets around STIL, producing a new stencil."
63
64   (let* ((ext (ly:stencil-extent stil axis))
65          (lb (ly:bracket axis ext thick (- protusion)))
66          (rb (ly:bracket axis ext thick protusion)))
67     (set! stil
68           (ly:stencil-combine-at-edge stil (other-axis axis) 1 lb padding))
69     (set! stil
70           (ly:stencil-combine-at-edge stil (other-axis axis) -1 rb padding))
71     stil))
72
73 (define-public (make-line-stencil width startx starty endx endy)
74   "Make a line stencil of given linewidth and set its extents accordingly"
75   (let ((xext (cons (min startx endx) (max startx endx)))
76         (yext (cons (min starty endy) (max starty endy))))
77     (ly:make-stencil
78       (list 'draw-line width startx starty endx endy)
79       ; Since the line has rounded edges, we have to / can safely add half the 
80       ; width to all coordinates!
81       (interval-widen xext (/ width 2))
82       (interval-widen yext (/ width 2)))))
83
84 (define-public (make-filled-box-stencil xext yext)
85   "Make a filled box."
86   
87   (ly:make-stencil
88       (list 'round-filled-box (- (car xext)) (cdr xext)
89                        (- (car yext)) (cdr yext) 0.0)
90       xext yext))
91
92 (define-public (make-circle-stencil radius thickness fill)
93   "Make a circle of radius @var{radius} and thickness @var{thickness}"
94   (let*
95       ((out-radius (+ radius (/ thickness 2.0))))
96     
97   (ly:make-stencil
98    (list 'circle radius thickness fill) 
99    (cons (- out-radius) out-radius)
100    (cons (- out-radius) out-radius))))
101
102 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
103   "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius},
104     and thickness @var{thickness} with fill defined by @code{fill}."
105   (let*
106       ((x-out-radius (+ x-radius (/ thickness 2.0))) 
107        (y-out-radius (+ y-radius (/ thickness 2.0))) )
108     
109   (ly:make-stencil
110    (list 'ellipse x-radius y-radius thickness fill) 
111    (cons (- x-out-radius) x-out-radius)
112    (cons (- y-out-radius) y-out-radius))))
113
114 (define-public (box-grob-stencil grob)
115   "Make a box of exactly the extents of the grob.  The box precisely
116 encloses the contents.
117 "
118   (let* ((xext (ly:grob-extent grob grob 0))
119          (yext (ly:grob-extent grob grob 1))
120          (thick 0.01))
121
122     (ly:stencil-add
123      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
124      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
125      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
126      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
127
128 ;; TODO merge this and prev function. 
129 (define-public (box-stencil stencil thickness padding)
130   "Add a box around STENCIL, producing a new stencil."
131   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
132          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
133          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
134          (x-rule (make-filled-box-stencil
135                   (interval-widen x-ext thickness) (cons 0 thickness))))
136     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
137     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
138     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))  
139     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
140     stencil))
141
142 (define-public (circle-stencil stencil thickness padding)
143   "Add a circle around STENCIL, producing a new stencil."
144   (let* ((x-ext (ly:stencil-extent stencil X))
145          (y-ext (ly:stencil-extent stencil Y))
146          (diameter (max (interval-length x-ext)
147                         (interval-length y-ext))) 
148          (radius (+ (/ diameter 2) padding thickness))
149          (circle (make-circle-stencil radius thickness #f)))
150
151     (ly:stencil-add
152      stencil
153      (ly:stencil-translate circle
154                            (cons
155                             (interval-center x-ext)
156                             (interval-center y-ext))))))
157
158 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
159   "Add an ellipse around STENCIL, padded by the padding pair, 
160    producing a new stencil."
161   (let* ((x-ext (ly:stencil-extent stencil X))
162          (y-ext (ly:stencil-extent stencil Y))
163          (x-length (+ (interval-length x-ext) x-padding thickness))
164          (y-length (+ (interval-length y-ext) y-padding thickness))
165          ;(aspect-ratio (/ x-length y-length))
166          (x-radius (* 0.707 x-length) )
167          (y-radius (* 0.707 y-length) )
168          ;(diameter (max (- (cdr x-ext) (car x-ext))
169          ;              (- (cdr y-ext) (car y-ext))))
170          ;(radius (+ (/ diameter 2) padding thickness))
171          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
172
173     (ly:stencil-add
174      stencil
175      (ly:stencil-translate ellipse
176                            (cons
177                             (interval-center x-ext)
178                             (interval-center y-ext))))))
179
180 (define-public (rounded-box-stencil stencil thickness padding blot)
181    "Add a rounded box around STENCIL, producing a new stencil."  
182
183   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
184          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
185    (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
186    (ideal-blot (min blot (/ min-ext 2)))
187    (ideal-thickness (min thickness (/ min-ext 2)))
188          (outer (ly:round-filled-box
189             (interval-widen xext ideal-thickness) 
190             (interval-widen yext ideal-thickness) 
191                ideal-blot))
192          (inner (ly:make-stencil (list 'color (x11-color 'white) 
193             (ly:stencil-expr (ly:round-filled-box 
194                xext yext (- ideal-blot ideal-thickness)))))))
195     (set! stencil (ly:stencil-add outer inner))
196     stencil))
197
198
199 (define-public (fontify-text font-metric text)
200   "Set TEXT with font FONT-METRIC, returning a stencil."
201   (let* ((b (ly:text-dimension font-metric text)))
202     (ly:make-stencil
203      `(text ,font-metric ,text) (car b) (cdr b))))
204      
205 (define-public (fontify-text-white scale font-metric text)
206   "Set TEXT with scale factor SCALE"
207   (let* ((b (ly:text-dimension font-metric text))
208          ;;urg -- workaround for using ps font
209          (c `(white-text ,(* 2 scale) ,text)))
210     ;;urg -- extent is not from ps font, but we hope it's close
211     (ly:make-stencil c (car b) (cdr b))))
212
213 (define-public (stencil-with-color stencil color)
214   (ly:make-stencil
215    (list 'color color (ly:stencil-expr stencil))
216    (ly:stencil-extent stencil X)
217    (ly:stencil-extent stencil Y)))
218   
219 (define-public (stencil-whiteout stencil)
220   (let*
221       ((x-ext (ly:stencil-extent stencil X))
222        (y-ext (ly:stencil-extent stencil Y))
223
224        )
225     
226     (ly:stencil-add
227      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
228                          white)
229      stencil)
230     ))
231
232 (define-public (dimension-arrows destination) 
233   "Draw twosided arrow from here to @var{destination}"
234   
235   (let*
236       ((e_x 1+0i)
237        (e_y 0+1i)
238        (rotate (lambda (z ang)
239                  (* (make-polar 1 ang)
240                     z)))
241        (complex-to-offset (lambda (z)
242                             (list (real-part z) (imag-part z))))
243        
244        (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
245        (e_z (/ z-dest (magnitude z-dest)))
246        (triangle-points '(-1+0.25i
247                           0
248                           -1-0.25i))
249        (p1s (map (lambda (z)
250                    (+ z-dest (rotate z (angle z-dest))))
251                  triangle-points))
252        (p2s (map (lambda (z)
253                    (rotate z (angle (- z-dest))))
254                    triangle-points))
255        (null (cons 0 0)) 
256        (arrow-1  
257         (ly:make-stencil
258          `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
259                    0.0
260                    #t) null null))
261        (arrow-2
262         (ly:make-stencil
263          `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
264                    0.0
265                    #t) null null ) )
266        (thickness 0.1)
267        (shorten-line 0.5)
268        (start (complex-to-offset (/ (* e_z shorten-line) 2)))
269        (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
270        
271        (line (ly:make-stencil
272               `(draw-line ,thickness
273                           ,(car start) ,(cadr start)
274                           ,(car end) ,(cadr end)
275                           )
276               (cons (min 0 (car destination))
277                     (min 0 (cdr destination)))
278               (cons (max 0 (car destination))
279                     (max 0 (cdr destination)))))
280                     
281        (result (ly:stencil-add arrow-2 arrow-1 line)))
282
283
284     result))
285
286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
287 ;; ANNOTATIONS
288 ;;
289 ;; annotations are arrows indicating the numerical value of
290 ;; spacing variables 
291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292
293 (define*-public (annotate-y-interval layout name extent is-length
294                                      #:key (color darkblue))
295   (let ((text-props (cons '((font-size . -3)
296                             (font-family . typewriter))
297                           (layout-extract-page-properties layout)))
298         (annotation #f))
299     (define (center-stencil-on-extent stil)
300       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
301                             (cons 0 (interval-center extent))))
302     ;; do something sensible for 0,0 intervals. 
303     (set! extent (interval-widen extent 0.001))
304     (if (not (interval-sane? extent))
305         (set! annotation (interpret-markup
306                           layout text-props
307                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
308         (let ((text-stencil (interpret-markup
309                              layout text-props
310                              (markup #:whiteout #:simple name)))
311               (dim-stencil (interpret-markup
312                             layout text-props
313                             (markup #:whiteout
314                                     #:simple (cond
315                                               ((interval-empty? extent)
316                                                (format "empty"))
317                                               (is-length
318                                                (ly:format "~$" (interval-length extent)))
319                                               (else
320                                                (ly:format "(~$,~$)"
321                                                        (car extent) (cdr extent)))))))
322               (arrows (ly:stencil-translate-axis 
323                        (dimension-arrows (cons 0 (interval-length extent)))
324                        (interval-start extent) Y)))
325           (set! annotation
326                 (center-stencil-on-extent text-stencil))
327           (set! annotation
328                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
329           (set! annotation
330                 (ly:stencil-combine-at-edge annotation X LEFT
331                                             (center-stencil-on-extent dim-stencil)
332                                             0.5))
333           (set! annotation
334                 (ly:make-stencil (list 'color color (ly:stencil-expr annotation))
335                                  (ly:stencil-extent annotation X)
336                                  (cons 10000 -10000)))))
337     annotation))
338
339
340 (define-public (eps-file->stencil axis size file-name)
341   (let*
342       ((contents (ly:gulp-file file-name))
343        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
344        (bbox-size (if (= axis X)
345                       (- (list-ref bbox 2) (list-ref bbox 0))
346                       (- (list-ref bbox 3) (list-ref bbox 1))
347                       ))
348        (factor (if (< 0 bbox-size)
349                    (exact->inexact (/ size bbox-size))
350                    0))
351        (scaled-bbox
352         (map (lambda (x) (* factor x)) bbox))
353        (clip-rect-string (ly:format
354                           "~a ~a ~a ~a rectclip"
355                           (list-ref bbox 0) 
356                           (list-ref bbox 1) 
357                           (- (list-ref bbox 2) (list-ref bbox 0))
358                           (- (list-ref bbox 3) (list-ref bbox 1)))))
359     
360
361     (if bbox
362         (ly:make-stencil
363          (list
364           'embedded-ps
365           (string-append
366            (ly:format
367            "
368 gsave
369 currentpoint translate
370 BeginEPSF
371 ~a dup scale
372 ~a 
373 %%BeginDocument: ~a
374 "          factor clip-rect-string
375
376            file-name
377            )
378            contents
379            "%%EndDocument
380 EndEPSF
381 grestore
382 "))
383         
384          (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2))
385          (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3)))
386         
387         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
388     ))
389
390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
391 ;; output signatures.
392
393 (define-public (write-system-signatures basename paper-systems count)
394   (if (pair? paper-systems)
395       (begin
396         (let*
397             ((outname (simple-format #f "~a-~a.signature" basename count)) )
398              
399           (ly:message "Writing ~a" outname)
400           (write-system-signature outname (car paper-systems))
401           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
402
403 (use-modules (scm paper-system))
404 (define-public (write-system-signature filename paper-system)
405   (define (float? x)
406     (and (number? x) (inexact? x)))
407
408   (define system-grob
409     (paper-system-system-grob paper-system))
410   
411   (define output (open-output-file filename))
412
413   ;; todo: optionally use a command line flag? Or just junk this?
414   (define compare-expressions #f)
415   (define (strip-floats expr)
416     "Replace floats by #f"
417     (cond
418      ((float? expr) #f)
419      ((ly:font-metric? expr) (ly:font-name expr))
420      ((pair? expr) (cons (strip-floats (car expr))
421                          (strip-floats (cdr expr))))
422      (else expr)))
423
424   (define (fold-false-pairs expr)
425     "Try to remove lists of #f as much as possible."
426     (if (pair? expr)
427         (let*
428             ((first (car expr))
429              (rest (fold-false-pairs (cdr expr))))
430
431           (if first
432               (cons (fold-false-pairs first) rest)
433               rest))
434         expr))
435   
436   (define (raw-string expr)
437     "escape quotes and slashes for python consumption"
438     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
439
440   (define (raw-pair expr)
441     (simple-format #f "~a ~a"
442             (car expr) (cdr expr)))
443   
444   (define (found-grob expr)
445     (let*
446         ((grob (car expr))
447          (rest (cdr expr))
448          (collected '())
449          (cause (event-cause grob))
450          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
451          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
452
453          ;; todo: use stencil extent if available.
454          (x-ext (ly:grob-extent grob system-grob X))
455          (y-ext (ly:grob-extent grob system-grob Y))
456          (expression-skeleton
457           (if compare-expressions
458               (interpret-for-signature
459                #f (lambda (e)
460                     (set! collected (cons e collected)))
461                rest)
462              "")))
463
464       (simple-format output
465               "~a@~a@~a@~a@~a\n"
466               (cdr (assq 'name (ly:grob-property grob 'meta) ))
467               (raw-string location)
468               (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
469               (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
470               (raw-string collected))
471       ))
472
473   (define (interpret-for-signature escape collect expr)
474     (define (interpret expr)
475       (let*
476           ((head (if (pair? expr)
477                      (car expr)
478                      #f)))
479
480         (cond
481          ((eq? head 'grob-cause) (escape (cdr expr)))
482          ((eq? head 'color) (interpret (caddr expr)))
483          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
484          ((eq? head 'translate-stencil) (interpret (caddr expr)))
485          ((eq? head 'combine-stencil)
486           (for-each (lambda (e) (interpret e))  (cdr expr)))
487          (else
488           (collect (fold-false-pairs (strip-floats expr))))
489          
490          )))
491
492     (interpret expr))
493
494   (if (ly:grob? system-grob)
495       (begin
496         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
497                  output)
498         (interpret-for-signature found-grob (lambda (x) #f)
499                                  (ly:stencil-expr
500                                   (paper-system-stencil paper-system)))))
501
502   ;; should be superfluous, but leaking "too many open files"?
503   (close-port output))
504