X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=0ecc9abe8ed4f4206f351b822d5973497b612013;hb=8e427e706929b903b6b7d0c3c7858c95ccf72c77;hp=446253c4f51623a50a1efe5e692e3b5272e6303a;hpb=ec2cc5bb24a4696ad7abb22c90a94154dbbe5f30;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index 446253c4f5..0ecc9abe8e 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2012 Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -15,8 +15,33 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see . +(define (make-bezier-sandwich-stencil coords thick xext yext) + (let* ((command-list `(moveto + ,(car (list-ref coords 3)) + ,(cdr (list-ref coords 3)) + curveto + ,(car (list-ref coords 0)) + ,(cdr (list-ref coords 0)) + ,(car (list-ref coords 1)) + ,(cdr (list-ref coords 1)) + ,(car (list-ref coords 2)) + ,(cdr (list-ref coords 2)) + curveto + ,(car (list-ref coords 4)) + ,(cdr (list-ref coords 4)) + ,(car (list-ref coords 5)) + ,(cdr (list-ref coords 5)) + ,(car (list-ref coords 6)) + ,(cdr (list-ref coords 6)) + closepath))) + (ly:make-stencil + `(path ,thick `(,@' ,command-list) 'round 'round #t) + xext + yext))) + (define-public (stack-stencils axis dir padding stils) - "Stack stencils STILS in direction AXIS, DIR, using PADDING." + "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using +@var{padding}." (cond ((null? stils) empty-stencil) ((null? (cdr stils)) (car stils)) @@ -25,7 +50,8 @@ padding)))) (define-public (stack-stencils-padding-list axis dir padding stils) - "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING." + "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using +a list of @var{padding}." (cond ((null? stils) empty-stencil) ((null? (cdr stils)) (car stils)) @@ -36,11 +62,11 @@ (car padding))))) (define-public (centered-stencil stencil) - "Center stencil @var{stencil} in both the X and Y directions" + "Center stencil @var{stencil} in both the X and Y directions." (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER)) (define-public (stack-lines dir padding baseline stils) - "Stack vertically with a baseline-skip." + "Stack vertically with a baseline skip." (define result empty-stencil) (define last-y #f) (do @@ -70,7 +96,7 @@ (define-public (bracketify-stencil stil axis thick protrusion padding) - "Add brackets around STIL, producing a new stencil." + "Add brackets around @var{stil}, producing a new stencil." (let* ((ext (ly:stencil-extent stil axis)) (lb (ly:bracket axis ext thick protrusion)) @@ -126,26 +152,25 @@ the more angular the shape of the parenthesis." (lower-inner-control-point (cons inner-control-x lower-control-y))) - (ly:make-stencil - (list 'bezier-sandwich - `(quote ,(list - ;; Step 4: curve through inner control points - ;; to lower end point. - upper-inner-control-point - lower-inner-control-point - lower-end-point - ;; Step 3: move to upper end point. - upper-end-point - ;; Step 2: curve through outer control points - ;; to upper end point. - lower-outer-control-point - upper-outer-control-point - upper-end-point - ;; Step 1: move to lower end point. - lower-end-point)) - line-width) - (interval-widen x-extent (/ line-width 2)) - (interval-widen y-extent (/ line-width 2))))) + (make-bezier-sandwich-stencil + (list + ;; Step 4: curve through inner control points + ;; to lower end point. + upper-inner-control-point + lower-inner-control-point + lower-end-point + ;; Step 3: move to upper end point. + upper-end-point + ;; Step 2: curve through outer control points + ;; to upper end point. + lower-outer-control-point + upper-outer-control-point + upper-end-point + ;; Step 1: move to lower end point. + lower-end-point) + line-width + (interval-widen x-extent (/ line-width 2)) + (interval-widen y-extent (/ line-width 2))))) (define-public (parenthesize-stencil stencil half-thickness width angularity padding) @@ -160,7 +185,7 @@ the more angular the shape of the parenthesis." stencil)) (define-public (make-line-stencil width startx starty endx endy) - "Make a line stencil of given linewidth and set its extents accordingly" + "Make a line stencil of given linewidth and set its extents accordingly." (let ((xext (cons (min startx endx) (max startx endx))) (yext (cons (min starty endy) (max starty endy)))) (ly:make-stencil @@ -180,7 +205,7 @@ the more angular the shape of the parenthesis." xext yext)) (define-public (make-circle-stencil radius thickness fill) - "Make a circle of radius @var{radius} and thickness @var{thickness}" + "Make a circle of radius @var{radius} and thickness @var{thickness}." (let* ((out-radius (+ radius (/ thickness 2.0)))) @@ -190,17 +215,25 @@ the more angular the shape of the parenthesis." (cons (- out-radius) out-radius)))) (define-public (make-oval-stencil x-radius y-radius thickness fill) - "Make an oval from two Bezier curves, of x radius @var{x-radius}, - y radius @code{y-radius}, - and thickness @var{thickness} with fill defined by @code{fill}." + "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius}, +y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill +defined by @code{fill}." (let* ((x-out-radius (+ x-radius (/ thickness 2.0))) - (y-out-radius (+ y-radius (/ thickness 2.0))) ) - + (y-out-radius (+ y-radius (/ thickness 2.0))) + (x-max x-radius) + (x-min (- x-radius)) + (y-max y-radius) + (y-min (- y-radius)) + (commands `(,(list 'moveto x-max 0) + ,(list 'curveto x-max y-max x-min y-max x-min 0) + ,(list 'curveto x-min y-min x-max y-min x-max 0) + ,(list 'closepath))) + (command-list (fold-right append '() commands))) (ly:make-stencil - (list 'oval x-radius y-radius thickness fill) - (cons (- x-out-radius) x-out-radius) - (cons (- y-out-radius) y-out-radius)))) + `(path ,thickness `(,@',command-list) 'round 'round ,fill) + (cons (- x-out-radius) x-out-radius) + (cons (- y-out-radius) y-out-radius)))) (define-public (make-partial-ellipse-stencil @@ -291,7 +324,7 @@ the more angular the shape of the parenthesis." (cons (min-max-crawler min cddr possible-extrema) (min-max-crawler max cddr possible-extrema))))) -(define (connected-shape-min-max origin pointlist) +(define (path-min-max origin pointlist) (define (line-part-min-max x1 x2) (list (min x1 x2) (max x1 x2))) @@ -356,25 +389,48 @@ the more angular the shape of the parenthesis." (append (list origin) (reverse (cdr (reverse pointlist)))) pointlist)))) -(define-public (make-connected-shape-stencil pointlist thickness - x-scale y-scale connect fill) - "Make a connected shape described by the list @var{pointlist}, with +(define-public (make-connected-path-stencil pointlist thickness + x-scale y-scale connect fill) + "Make a connected path described by the list @var{pointlist}, with thickness @var{thickness}, and scaled by @var{x-scale} in the X direction and @var{y-scale} in the Y direction. @var{connect} and @var{fill} are -boolean arguments that specify if the shape should be connected or filled, +boolean arguments that specify if the path should be connected or filled, respectively." - ;; a connected shape path must begin at point '(0 . 0) + ;; paths using this routine are designed to begin at point '(0 . 0) (let* ((origin (list 0 0)) - (boundlist (connected-shape-min-max origin pointlist))) + (boundlist (path-min-max origin pointlist)) + ;; modify pointlist to scale the coordinates + (path (map (lambda (x) + (apply + (if (eq? 6 (length x)) + (lambda (x1 x2 x3 x4 x5 x6) + (list 'curveto + (* x1 x-scale) + (* x2 y-scale) + (* x3 x-scale) + (* x4 y-scale) + (* x5 x-scale) + (* x6 y-scale))) + (lambda (x1 x2) + (list 'lineto + (* x1 x-scale) + (* x2 y-scale)))) + x)) + pointlist)) + ;; a path must begin with a `moveto' + (prepend-origin (apply list (cons 'moveto origin) path)) + ;; if this path is connected, add closepath to the end + (final-path (if connect + (append prepend-origin (list 'closepath)) + prepend-origin)) + (command-list (fold-right append '() final-path))) (ly:make-stencil - `(connected-shape - ',pointlist - ',thickness - ',x-scale - ',y-scale - ',connect - ',fill) + `(path ,thickness + `(,@',command-list) + 'round + 'round + ,(if fill #t #f)) (coord-translate ((if (< x-scale 0) reverse-interval identity) (cons (* x-scale (list-ref boundlist 0)) @@ -387,8 +443,9 @@ respectively." `(,(/ thickness -2) . ,(/ thickness 2)))))) (define-public (make-ellipse-stencil x-radius y-radius thickness fill) - "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius}, - and thickness @var{thickness} with fill defined by @code{fill}." + "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius +@code{y-radius}, and thickness @var{thickness} with fill defined by +@code{fill}." (let* ((x-out-radius (+ x-radius (/ thickness 2.0))) (y-out-radius (+ y-radius (/ thickness 2.0))) ) @@ -400,8 +457,7 @@ respectively." (define-public (box-grob-stencil grob) "Make a box of exactly the extents of the grob. The box precisely -encloses the contents. -" +encloses the contents." (let* ((xext (ly:grob-extent grob grob 0)) (yext (ly:grob-extent grob grob 1)) (thick 0.01)) @@ -414,7 +470,7 @@ encloses the contents. ;; TODO merge this and prev function. (define-public (box-stencil stencil thickness padding) - "Add a box around STENCIL, producing a new stencil." + "Add a box around @var{stencil}, producing a new stencil." (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding)) (y-ext (interval-widen (ly:stencil-extent stencil 1) padding)) (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext)) @@ -427,7 +483,7 @@ encloses the contents. stencil)) (define-public (circle-stencil stencil thickness padding) - "Add a circle around STENCIL, producing a new stencil." + "Add a circle around @var{stencil}, producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) (diameter (max (interval-length x-ext) @@ -444,7 +500,7 @@ encloses the contents. (define-public (oval-stencil stencil thickness x-padding y-padding) "Add an oval around @code{stencil}, padded by the padding pair, - producing a new stencil." +producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) (x-length (+ (interval-length x-ext) x-padding thickness)) @@ -461,8 +517,8 @@ encloses the contents. (interval-center y-ext)))))) (define-public (ellipse-stencil stencil thickness x-padding y-padding) - "Add an ellipse around STENCIL, padded by the padding pair, - producing a new stencil." + "Add an ellipse around @var{stencil}, padded by the padding pair, +producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) (x-length (+ (interval-length x-ext) x-padding thickness)) @@ -483,7 +539,7 @@ encloses the contents. (interval-center y-ext)))))) (define-public (rounded-box-stencil stencil thickness padding blot) - "Add a rounded box around STENCIL, producing a new stencil." + "Add a rounded box around @var{stencil}, producing a new stencil." (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding)) (yext (interval-widen (ly:stencil-extent stencil 1) padding)) @@ -520,9 +576,9 @@ encloses the contents. )) (define-public (arrow-stencil-maker start? end?) - "Returns a function drawing a line from current point to @var{destination}, - with optional arrows of @var{max-size} on start and end controlled by - @var{start?} and @var{end?}." + "Return a function drawing a line from current point to @code{destination}, +with optional arrows of @code{max-size} on start and end controlled by +@var{start?} and @var{end?}." (lambda (destination max-size) (let* ((e_x 1+0i) @@ -614,7 +670,7 @@ encloses the contents. (markup #:whiteout #:simple (cond ((interval-empty? extent) - (format "empty")) + "empty") (is-length (ly:format "~$" (interval-length extent))) (else @@ -632,43 +688,43 @@ encloses the contents. (center-stencil-on-extent dim-stencil) 0.5)) (set! annotation - (ly:make-stencil (list 'color color (ly:stencil-expr annotation)) - (ly:stencil-extent annotation X) - (cons 10000 -10000))))) + (stencil-with-color annotation color)))) annotation)) -(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end +;; TODO: figure out how to annotate padding nicely +;; TODO: emphasize either padding or min-dist depending on which constraint was active +(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y #:key (base-color blue)) - (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0))) - (space (get-spacing-var 'space)) + (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0))) + (space (get-spacing-var 'basic-distance)) (padding (get-spacing-var 'padding)) (min-dist (get-spacing-var 'minimum-distance)) - (contrast-color (append (cdr base-color) (list (car base-color))))) + (contrast-color (append (cdr base-color) (list (car base-color)))) + (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y)) + (min-dist-color (if min-dist-blocks contrast-color base-color)) + (basic-annotation (annotate-y-interval layout + "basic-dist" + (cons (- start-Y-offset space) start-Y-offset) + #t + #:color (map (lambda (x) (* x 0.25)) base-color))) + (min-annotation (annotate-y-interval layout + "min-dist" + (cons (- start-Y-offset min-dist) start-Y-offset) + #t + #:color min-dist-color)) + (extra-annotation (annotate-y-interval layout + "extra dist" + (cons next-staff-Y (- start-Y-offset min-dist)) + #t + #:color (map (lambda (x) (* x 0.5)) min-dist-color)))) + (stack-stencils X RIGHT 0.0 (list - (annotate-y-interval layout - "space" - (cons (- start-Y-offset space) start-Y-offset) - #t - #:color (map (lambda (x) (* x 0.25)) base-color)) - (annotate-y-interval layout - "min-dist" - (cons (- start-Y-offset min-dist) start-Y-offset) - #t - #:color (map (lambda (x) (* x 0.5)) base-color)) - (ly:stencil-add - (annotate-y-interval layout - "bottom-of-extent" - (cons prev-system-end start-Y-offset) - #t - #:color base-color) - (annotate-y-interval layout - "padding" - (cons (- prev-system-end padding) prev-system-end) - #t - #:color contrast-color)))))) - + basic-annotation + (if min-dist-blocks + min-annotation + (ly:stencil-add min-annotation extra-annotation)))))) (define-public (eps-file->stencil axis size file-name) (let*