LEFT | RIGHT |
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | 1 ;;;; This file is part of LilyPond, the GNU music typesetter. |
2 ;;;; | 2 ;;;; |
3 ;;;; Copyright (C) 2002--2012 Jan Nieuwenhuizen <janneke@gnu.org> | 3 ;;;; Copyright (C) 2002--2012 Jan Nieuwenhuizen <janneke@gnu.org> |
4 ;;;; Patrick McCarty <pnorcks@gmail.com> | 4 ;;;; Patrick McCarty <pnorcks@gmail.com> |
5 ;;;; | 5 ;;;; |
6 ;;;; LilyPond is free software: you can redistribute it and/or modify | 6 ;;;; LilyPond is free software: you can redistribute it and/or modify |
7 ;;;; it under the terms of the GNU General Public License as published by | 7 ;;;; it under the terms of the GNU General Public License as published by |
8 ;;;; the Free Software Foundation, either version 3 of the License, or | 8 ;;;; the Free Software Foundation, either version 3 of the License, or |
9 ;;;; (at your option) any later version. | 9 ;;;; (at your option) any later version. |
10 ;;;; | 10 ;;;; |
(...skipping 226 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
237 (ly:warning (_ "Glyph must have a unicode value"))) | 237 (ly:warning (_ "Glyph must have a unicode value"))) |
238 | 238 |
239 (if d-attr? (set! d-attr-value (match:substring d-attr 1))) | 239 (if d-attr? (set! d-attr-value (match:substring d-attr 1))) |
240 | 240 |
241 (cond ( | 241 (cond ( |
242 ;; Glyph-strings with path data | 242 ;; Glyph-strings with path data |
243 (and d-attr? (not (null? rest))) | 243 (and d-attr? (not (null? rest))) |
244 (begin | 244 (begin |
245 (set! path (apply dump-path d-attr-value | 245 (set! path (apply dump-path d-attr-value |
246 font-scale | 246 font-scale |
247 » » » » » (list (cadr rest) (caddr rest)))) | 247 » » » » » (list (caddr rest) (cadddr rest)))) |
248 (set! next-horiz-adv (+ next-horiz-adv | 248 (set! next-horiz-adv (+ next-horiz-adv |
249 (car rest))) | 249 (car rest))) |
250 path)) | 250 path)) |
251 ;; Glyph-strings without path data ("space") | 251 ;; Glyph-strings without path data ("space") |
252 ((and (not d-attr?) (not (null? rest))) | 252 ((and (not d-attr?) (not (null? rest))) |
253 (begin | 253 (begin |
254 (set! next-horiz-adv (+ next-horiz-adv | 254 (set! next-horiz-adv (+ next-horiz-adv |
255 (car rest))) | 255 (car rest))) |
256 "")) | 256 "")) |
257 ;; Font smobs with path data | 257 ;; Font smobs with path data |
258 ((and d-attr? (null? rest)) | 258 ((and d-attr? (null? rest)) |
259 (set! path (dump-path d-attr-value font-scale)) | 259 (set! path (dump-path d-attr-value font-scale)) |
260 path) | 260 path) |
261 ;; Font smobs without path data ("space") | 261 ;; Font smobs without path data ("space") |
262 (else | 262 (else |
263 "")))) | 263 "")))) |
264 | 264 |
265 (define (extract-glyph-info all-glyphs glyph size) | 265 (define (extract-glyph-info all-glyphs glyph size) |
266 (let* ((offsets (list-head glyph 3)) | 266 (let* ((offsets (list-head glyph 4)) |
267 (glyph-name (car (reverse glyph)))) | 267 (glyph-name (car (reverse glyph)))) |
268 (apply extract-glyph all-glyphs glyph-name size offsets))) | 268 (apply extract-glyph all-glyphs glyph-name size offsets))) |
269 | 269 |
270 (define (svg-defs svg-font) | 270 (define (svg-defs svg-font) |
271 (let ((start (string-contains svg-font "<defs>")) | 271 (let ((start (string-contains svg-font "<defs>")) |
272 (end (string-contains svg-font "</defs>"))) | 272 (end (string-contains svg-font "</defs>"))) |
273 (substring svg-font (+ start 7) (- end 1)))) | 273 (substring svg-font (+ start 7) (- end 1)))) |
274 | 274 |
275 (define (cache-font svg-font size glyph) | 275 (define (cache-font svg-font size glyph) |
276 (let ((all-glyphs (svg-defs (cached-file-contents svg-font)))) | 276 (let ((all-glyphs (svg-defs (cached-file-contents svg-font)))) |
(...skipping 44 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
321 font-smob-to-path woff-font-smob-to-text)) | 321 font-smob-to-path woff-font-smob-to-text)) |
322 | 322 |
323 (define (fontify font expr) | 323 (define (fontify font expr) |
324 (if (string? font) | 324 (if (string? font) |
325 (pango-description-to-text font expr) | 325 (pango-description-to-text font expr) |
326 (font-smob-to-text font expr))) | 326 (font-smob-to-text font expr))) |
327 | 327 |
328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | 328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
329 ;;; stencil outputters | 329 ;;; stencil outputters |
330 ;;; | 330 ;;; |
331 | |
332 (define (bezier-sandwich lst thick) | |
333 (let* ((first (list-tail lst 4)) | |
334 (second (list-head lst 4))) | |
335 (entity 'path "" | |
336 '(stroke-linejoin . "round") | |
337 '(stroke-linecap . "round") | |
338 '(stroke . "currentColor") | |
339 '(fill . "currentColor") | |
340 `(stroke-width . ,thick) | |
341 `(d . ,(string-append (svg-bezier first #f) | |
342 (svg-bezier second #t)))))) | |
343 | 331 |
344 (define (char font i) | 332 (define (char font i) |
345 (dispatch | 333 (dispatch |
346 `(fontify ,font ,(entity 'tspan (char->entity (integer->char i)))))) | 334 `(fontify ,font ,(entity 'tspan (char->entity (integer->char i)))))) |
347 | 335 |
348 (define (circle radius thick is-filled) | 336 (define (circle radius thick is-filled) |
349 (entity | 337 (entity |
350 'circle "" | 338 'circle "" |
351 '(stroke-linejoin . "round") | 339 '(stroke-linejoin . "round") |
352 '(stroke-linecap . "round") | 340 '(stroke-linecap . "round") |
(...skipping 80 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
433 (- (* end-radius (sin new-end-angle)))) | 421 (- (* end-radius (sin new-end-angle)))) |
434 (if connect | 422 (if connect |
435 (ly:format "L~4f,~4f" | 423 (ly:format "L~4f,~4f" |
436 (* start-radius (cos new-start-angle)) | 424 (* start-radius (cos new-start-angle)) |
437 (- (* start-radius (sin new-start-angle)))) | 425 (- (* start-radius (sin new-start-angle)))) |
438 ""))))))) | 426 ""))))))) |
439 | 427 |
440 (define (embedded-svg string) | 428 (define (embedded-svg string) |
441 string) | 429 string) |
442 | 430 |
443 (define (embedded-glyph-string font size cid glyphs bounding-box) | 431 (define (embedded-glyph-string pango-font font size cid glyphs) |
444 (define path "") | 432 (define path "") |
445 (if (= 1 (length glyphs)) | 433 (if (= 1 (length glyphs)) |
446 (set! path (music-string-to-path font size (car glyphs))) | 434 (set! path (music-string-to-path font size (car glyphs))) |
447 (begin | 435 (begin |
448 (set! path | 436 (set! path |
449 (string-append (eo 'g) | 437 (string-append (eo 'g) |
450 (string-join | 438 (string-join |
451 (map (lambda (x) | 439 (map (lambda (x) |
452 (music-string-to-path font size x)) | 440 (music-string-to-path font size x)) |
453 glyphs) | 441 glyphs) |
454 "\n") | 442 "\n") |
455 (ec 'g))))) | 443 (ec 'g))))) |
456 (set! next-horiz-adv 0.0) | 444 (set! next-horiz-adv 0.0) |
457 path) | 445 path) |
458 | 446 |
459 (define (woff-glyph-string font-name size cid? w-x-y-named-glyphs bounding-box) | 447 (define (woff-glyph-string pango-font font-name size cid? w-h-x-y-named-glyphs) |
460 (let* ((name-style (font-name-style font-name)) | 448 (let* ((name-style (font-name-style font-name)) |
461 (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)") | 449 (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)") |
462 font-name)) | 450 font-name)) |
463 (family (if (regexp-match? family-designsize) | 451 (family (if (regexp-match? family-designsize) |
464 (match:substring family-designsize 1) | 452 (match:substring family-designsize 1) |
465 font-name)) | 453 font-name)) |
466 (design-size (if (regexp-match? family-designsize) | 454 (design-size (if (regexp-match? family-designsize) |
467 (match:substring family-designsize 2) | 455 (match:substring family-designsize 2) |
468 #f)) | 456 #f)) |
469 (scaled-size (/ size lily-unit-length)) | 457 (scaled-size (/ size lily-unit-length)) |
470 (font (ly:paper-get-font paper `(((font-family . ,family) | 458 (font (ly:paper-get-font paper `(((font-family . ,family) |
471 ,(if design-size | 459 ,(if design-size |
472 `(design-size . design-size)))))
)) | 460 `(design-size . design-size)))))
)) |
473 (define (glyph-spec w x y g) | 461 (define (glyph-spec w h x y g) ; h not used |
474 (let* ((charcode (ly:font-glyph-name-to-charcode font g)) | 462 (let* ((charcode (ly:font-glyph-name-to-charcode font g)) |
475 (char-lookup (format #f "&#~S;" charcode)) | 463 (char-lookup (format #f "&#~S;" charcode)) |
476 (glyph-by-name (eoc 'altglyph `(glyphname . ,g))) | 464 (glyph-by-name (eoc 'altglyph `(glyphname . ,g))) |
477 (apparently-broken | 465 (apparently-broken |
478 (comment "XFIXME: how to select glyph by name, altglyph is broken?
"))) | 466 (comment "XFIXME: how to select glyph by name, altglyph is broken?
"))) |
479 ;; what is W? | 467 ;; what is W? |
480 (ly:format | 468 (ly:format |
481 "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>" | 469 "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>" |
482 (if (or (> (abs x) 0.00001) | 470 (if (or (> (abs x) 0.00001) |
483 (> (abs y) 0.00001)) | 471 (> (abs y) 0.00001)) |
484 (ly:format " transform=\"translate(~4f,~4f)\"" x y) | 472 (ly:format " transform=\"translate(~4f,~4f)\"" x y) |
485 " ") | 473 " ") |
486 name-style scaled-size | 474 name-style scaled-size |
487 (string-regexp-substitute | 475 (string-regexp-substitute |
488 "\n" "" | 476 "\n" "" |
489 (string-append glyph-by-name apparently-broken char-lookup))))) | 477 (string-append glyph-by-name apparently-broken char-lookup))))) |
490 | 478 |
491 (string-join (map (lambda (x) (apply glyph-spec x)) | 479 (string-join (map (lambda (x) (apply glyph-spec x)) |
492 » » (reverse w-x-y-named-glyphs)) "\n"))) | 480 » » (reverse w-h-x-y-named-glyphs)) "\n"))) |
493 | 481 |
494 (define glyph-string | 482 (define glyph-string |
495 (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string)) | 483 (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string)) |
496 | 484 |
497 (define (grob-cause offset grob) | 485 (define (grob-cause offset grob) |
498 "") | 486 "") |
499 | 487 |
500 (define (named-glyph font name) | 488 (define (named-glyph font name) |
501 (dispatch `(fontify ,font ,name))) | 489 (dispatch `(fontify ,font ,name))) |
502 | 490 |
503 (define (no-origin) | 491 (define (no-origin) |
504 "") | 492 "") |
505 | |
506 (define (oval x-radius y-radius thick is-filled) | |
507 (let ((x-max x-radius) | |
508 (x-min (- x-radius)) | |
509 (y-max y-radius) | |
510 (y-min (- y-radius))) | |
511 (entity | |
512 'path "" | |
513 '(stroke-linejoin . "round") | |
514 '(stroke-linecap . "round") | |
515 `(fill . ,(if is-filled "currentColor" "none")) | |
516 `(stroke . "currentColor") | |
517 `(stroke-width . ,thick) | |
518 `(d . ,(ly:format "M~4f ~4fC~4f ~4f ~4f ~4f ~4f ~4fS~4f ~4f ~4f ~4fz" | |
519 x-max 0 | |
520 x-max y-max | |
521 x-min y-max | |
522 x-min 0 | |
523 x-max y-min | |
524 x-max 0))))) | |
525 | 493 |
526 (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f)) | 494 (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f)) |
527 (define (convert-path-exps exps) | 495 (define (convert-path-exps exps) |
528 (if (pair? exps) | 496 (if (pair? exps) |
529 (let* | 497 (let* |
530 ((head (car exps)) | 498 ((head (car exps)) |
531 (rest (cdr exps)) | 499 (rest (cdr exps)) |
532 (arity | 500 (arity |
533 (cond ((memq head '(rmoveto rlineto lineto moveto)) 2) | 501 (cond ((memq head '(rmoveto rlineto lineto moveto)) 2) |
534 ((memq head '(rcurveto curveto)) 6) | 502 ((memq head '(rcurveto curveto)) 6) |
(...skipping 62 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
597 (entity | 565 (entity |
598 'polygon "" | 566 'polygon "" |
599 '(stroke-linejoin . "round") | 567 '(stroke-linejoin . "round") |
600 '(stroke-linecap . "round") | 568 '(stroke-linecap . "round") |
601 `(stroke-width . ,blot-diameter) | 569 `(stroke-width . ,blot-diameter) |
602 `(fill . ,(if is-filled "currentColor" "none")) | 570 `(fill . ,(if is-filled "currentColor" "none")) |
603 '(stroke . "currentColor") | 571 '(stroke . "currentColor") |
604 `(points . ,(string-join | 572 `(points . ,(string-join |
605 (map offset->point (ly:list->offsets '() coords)))))) | 573 (map offset->point (ly:list->offsets '() coords)))))) |
606 | 574 |
607 (define (repeat-slash width slope thickness) | |
608 (define (euclidean-length x y) | |
609 (sqrt (+ (* x x) (* y y)))) | |
610 (let* ((x-width (euclidean-length thickness (/ thickness slope))) | |
611 (height (* width slope))) | |
612 (entity | |
613 'path "" | |
614 '(fill . "currentColor") | |
615 `(d . ,(ly:format "M0 0l~4f 0 ~4f ~4f ~4f 0z" | |
616 x-width width (- height) (- x-width)))))) | |
617 | |
618 (define (resetcolor) | 575 (define (resetcolor) |
619 "</g>\n") | 576 "</g>\n") |
620 | 577 |
621 (define (resetrotation ang x y) | 578 (define (resetrotation ang x y) |
622 "</g>\n") | 579 "</g>\n") |
623 | 580 |
624 (define (resetscale) | 581 (define (resetscale) |
625 "</g>\n") | 582 "</g>\n") |
626 | 583 |
627 (define (round-filled-box breapth width depth height blot-diameter) | 584 (define (round-filled-box breapth width depth height blot-diameter) |
(...skipping 42 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
670 '(stroke . "none") | 627 '(stroke . "none") |
671 '(stroke-width . "0.0")) | 628 '(stroke-width . "0.0")) |
672 (ec 'a))) | 629 (ec 'a))) |
673 | 630 |
674 (define (utf-8-string pango-font-description string) | 631 (define (utf-8-string pango-font-description string) |
675 (let ((escaped-string (string-regexp-substitute | 632 (let ((escaped-string (string-regexp-substitute |
676 "<" "<" | 633 "<" "<" |
677 (string-regexp-substitute "&" "&" string)))) | 634 (string-regexp-substitute "&" "&" string)))) |
678 (dispatch `(fontify ,pango-font-description | 635 (dispatch `(fontify ,pango-font-description |
679 ,(entity 'tspan escaped-string))))) | 636 ,(entity 'tspan escaped-string))))) |
LEFT | RIGHT |