From 232eaf8f934cc2b7e96ca9d87e6f24a7655dbc67 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Tue, 4 Apr 2006 10:21:56 +0000 Subject: [PATCH] *** empty log message *** --- ChangeLog | 3 +- THANKS | 1 + ps/music-drawing-routines.ps | 99 ++++++++++++++++++++---------------- scm/output-ps.scm | 37 ++++++-------- 4 files changed, 75 insertions(+), 65 deletions(-) diff --git a/ChangeLog b/ChangeLog index fe23144e71..ce91f6dd18 100644 --- a/ChangeLog +++ b/ChangeLog @@ -45,7 +45,8 @@ 2006-04-03 Han-Wen Nienhuys - * scm/music-functions.scm (quote-substitute): set iterators-ctor. Backportme. + * scm/music-functions.scm (quote-substitute): set + iterators-ctor. Backportme. 2006-03-31 Han-Wen Nienhuys diff --git a/THANKS b/THANKS index d54089c11f..b9f5f93a54 100644 --- a/THANKS +++ b/THANKS @@ -14,6 +14,7 @@ CONTRIBUTORS David Feuer Joe Neeman +Erlend Aasland SPONSORS diff --git a/ps/music-drawing-routines.ps b/ps/music-drawing-routines.ps index cb9c6020b3..1ceab9a64b 100644 --- a/ps/music-drawing-routines.ps +++ b/ps/music-drawing-routines.ps @@ -118,20 +118,39 @@ bind def fill } bind def -/draw_round_box % x y width height blot -{ +/vector_add { % x1 y1 x2 y2 vector_add x1+x2 y1+y2 + exch + 4 1 roll + add + 3 1 roll + add + exch +} bind def + +/draw_round_box % width height x y blot +currentdict /testing known +{{ + setlinewidth + 0 setlinecap + 1 setlinejoin + + rmoveto + currentpoint + 4 2 roll + rectstroke +}} +{{ setlinewidth 0 setlinecap 1 setlinejoin - currentdict /testing known { - %% outline only, for testing: - }{ - 4 copy - rectfill - } ifelse + rmoveto + currentpoint + 4 2 roll + 4 copy + rectfill rectstroke -} bind def +}} ifelse bind def /draw_polygon % fill? x(n) y(n) x(n-1) y(n-1) ... x(0) y(0) n blot { @@ -141,8 +160,12 @@ bind def 1 setlinejoin 3 1 roll - moveto % x(0) y(0) - { lineto } repeat % n times + /polygon_x + currentpoint + /polygon_y exch def + def + rmoveto % x(0) y(0) + { polygon_x polygon_y vector_add lineto } repeat % n times closepath { %fill? stroke_and_fill @@ -157,7 +180,6 @@ bind def 1 setlinecap 1 setlinejoin - 0 0 moveto 0 rlineto % x-width 0 rlineto % width height neg 0 rlineto % -x-width 0 @@ -167,6 +189,8 @@ bind def % this is for drawing slurs. /draw_bezier_sandwich % thickness controls { + gsave + currentpoint translate % round ending and round beginning 1 setlinejoin 1 setlinecap setlinewidth @@ -176,19 +200,22 @@ bind def curveto closepath stroke_and_fill + grestore } bind def -/draw_dot % x1 y2 R +/draw_dot % radius x y { -% 0 360 arc fill stroke + rmoveto + currentpoint + 3 2 roll 0 360 arc closepath stroke_and_fill } bind def /draw_circle % F R T { setlinewidth - dup 0 moveto - 0 exch 0 exch + dup 0 rmoveto + currentpoint 3 2 roll 0 360 arc closepath { stroke_and_fill } { stroke } @@ -196,52 +223,38 @@ bind def } bind def -% JUNKME. use color & circle. -/draw_white_dot % x1 y2 R +/draw_line % dx dy x1 y1 thickness { -% 0 360 arc fill stroke - 0 360 arc closepath % fill stroke -gsave - 1 setgray fill -grestore -% 0 360 arc closepath % fill stroke - 0.05 setlinewidth 0 setgray stroke -} bind def - - -% JUNKME: Use color. -/draw_white_text % text scale font -{ - exch selectfont - 1 setgray - 0 0 moveto - %-0.05 -0.05 moveto - % text - show + setlinewidth + 1 setlinecap + 1 setlinejoin + rmoveto + rlineto + stroke } bind def - -/draw_dashed_line % dash thickness dx dy +/draw_dashed_line % dx dy thickness dashpattern { 1 setlinecap 1 setlinejoin setdash setlinewidth - 0 0 moveto - lineto + rlineto stroke } bind def -/draw_dashed_slur % dash thickness controls +/draw_dashed_slur % controls thickness dash { +gsave + currentpoint translate 1 setlinecap 1 setlinejoin setdash setlinewidth - 8 -2 roll moveto curveto stroke +grestore } bind def /print_glyphs { diff --git a/scm/output-ps.scm b/scm/output-ps.scm index dc20266a01..2303bf2d02 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -122,22 +122,23 @@ ;; what the heck is this interface ? (define (dashed-slur thick on off l) (format #f "~a ~a [ ~a ~a ] 0 draw_dashed_slur" - (string-join (map number-pair->string4 l) " ") + (let ((control-points (append (cddr l) (list (car l) (cadr l))))) + (string-join (map number-pair->string4 control-points) " ")) (str4 thick) (str4 on) (str4 off))) (define (dot x y radius) (format #f " ~a draw_dot" - (numbers->string4 (list x y radius)))) + (numbers->string4 (list radius x y)))) (define (draw-line thick x1 y1 x2 y2) - (format #f "1 setlinecap 1 setlinejoin ~a setlinewidth ~a ~a moveto ~a ~a lineto stroke" - (str4 thick) - (str4 x1) - (str4 y1) - (str4 x2) - (str4 y2))) + (format #f "~a ~a ~a ~a ~a draw_line" + (str4 (- x2 x1)) + (str4 (- y2 y1)) + (str4 x1) + (str4 y1) + (str4 thick))) (define (embedded-ps string) string) @@ -156,16 +157,13 @@ (format #f (if cid? -"gsave -/~a /CIDFont findresource ~a output-scale div scalefont setfont +"/~a /CIDFont findresource ~a output-scale div scalefont setfont ~a -~a print_glyphs -grestore" +~a print_glyphs" -"gsave\n/~a ~a output-scale div selectfont +"/~a ~a output-scale div selectfont ~a -~a print_glyphs -grestore") +~a print_glyphs") postscript-font-name size (string-join (map (lambda (x) (apply glyph-spec x)) @@ -224,11 +222,8 @@ grestore") (define (placebox x y s) (format #f -"gsave ~a ~a translate -0 0 moveto -~a -grestore\n" - +"~a ~a moveto +~a\n" (str4 x) (str4 y) s)) @@ -260,7 +255,7 @@ grestore\n" (height (- top (+ halfblot y)))) (format #f "~a draw_round_box" (numbers->string4 - (list x y width height blotdiam))))) + (list width height x y blotdiam))))) ;; save current color on stack and set new color (define (setcolor r g b) -- 2.39.2