From e58f03944cce661e4732af3e63aeb60edae97846 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Tue, 4 Apr 2006 10:13:04 +0000 Subject: [PATCH 1/1] *** empty log message *** --- ChangeLog | 24 ++++ Documentation/topdocs/AUTHORS.texi | 4 +- ps/lilyponddefs.ps | 3 +- ps/music-drawing-routines.ps | 203 ++++++++++++----------------- scm/framework-ps.scm | 3 - scm/output-ps.scm | 98 ++++++++------ 6 files changed, 168 insertions(+), 167 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4d9f264d82..1a0694babe 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,27 @@ +2006-04-03 David Feuer + + * lilyponddefs.ps (set-ps-scale-to-lily-scale): Fixed code duplication. + + * Cleaned up interfaces between PostScript and Scheme, and moved + computations from PostScript to Scheme: + + * music-drawing-routines.ps + (*SF, stroke_and_fill): new procedures. Replaced stroke and fill + with stroke_and_fill throughout. + (euclidean_length, print_letter, draw_box): Deleted unused + procedures. If someone needs draw_box, implement it using + draw_round_box; don't duplicate code. + (print_glyphs, draw_round_box, draw_polygon, draw_repeat_slash): + Refactored/cleaned up interfaces. + (mark_URI): Moved. + + * output-ps.scm: reordered arguments to PostScript functions to + match new interfaces + (glyph-string): Rewrote glyph-string. + (grob-cause): Replaced string-append with format. + (repeat-slash): Rewrote to do computation here. + (round-filled-box): Rewrote to do computation here. + 2006-04-04 Erlend Aasland * stepmake/stepmake/generic-targets.make: add cvs-clean target diff --git a/Documentation/topdocs/AUTHORS.texi b/Documentation/topdocs/AUTHORS.texi index 25a9400aeb..db201896ad 100644 --- a/Documentation/topdocs/AUTHORS.texi +++ b/Documentation/topdocs/AUTHORS.texi @@ -24,7 +24,9 @@ Core code: @itemize @bullet @item @email{erlenda@@gmail.com,Erlend Aasland} - Color support, tablature improvements, trivial \mark stuff + Color support, tablature improvements, trivial \mark stuff, +al-niente hairpins. + @item @email{benkop@@freestart.hu,Pal Benko}, Ancient notation. @item @email{david.feuer@@gmail.com, David Feuer}, diff --git a/ps/lilyponddefs.ps b/ps/lilyponddefs.ps index 7243731913..442ae20046 100644 --- a/ps/lilyponddefs.ps +++ b/ps/lilyponddefs.ps @@ -11,8 +11,7 @@ /set-ps-scale-to-lily-scale { - lily-output-units output-scale mul - lily-output-units output-scale mul scale + lily-output-units output-scale mul dup scale } bind def diff --git a/ps/music-drawing-routines.ps b/ps/music-drawing-routines.ps index cb2249d4b4..cb9c6020b3 100644 --- a/ps/music-drawing-routines.ps +++ b/ps/music-drawing-routines.ps @@ -7,9 +7,60 @@ % TODO: use dicts or prefixes to prevent namespace pollution. +% Emulation code from Postscript Language Reference. + +/*SF +{ + exch findfont exch + dup type /arraytype eq + {makefont} + {scalefont} + ifelse + setfont +} bind def + +/languagelevel where + {pop languagelevel} + {1} +ifelse + +2 lt + { /selectfont /*SF load def } +if + +% end emulation code + /pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse + +% llx lly urx ury URI +/mark_URI +% It's possible to eliminate the coordinate variables by doing [ /Rect [ 7 3 +% roll. That is, however, kind of ugly. It would be nice if this procedure +% were only included when PDF marks are enabled. +{ + /command exch def + /ury exch def + /urx exch def + /lly exch def + /llx exch def + [ + /Rect [ llx lly urx ury ] + + /Border [ 0 0 0 ] + + /Action + << + /Subtype /URI + /URI command + >> + /Subtype /Link + /ANN + pdfmark +} +bind def + % from adobe tech note 5002. /BeginEPSF { %def /b4_Inc_state save def % Save state for cleanup @@ -28,7 +79,6 @@ } if } bind def - /EndEPSF { %def count op_count sub {pop} repeat % Clean up stacks countdictstack dict_count sub {end} repeat @@ -54,28 +104,6 @@ } bind def -% llx lly urx ury URI -/mark_URI -{ - /command exch def - /ury exch def - /urx exch def - /lly exch def - /llx exch def - [ - /Rect [ llx lly urx ury ] - /Border [ 0 0 0 ] - - /Action - << - /Subtype /URI - /URI command - >> - /Subtype /Link - /ANN - pdfmark -} -bind def /set_tex_dimen { @@ -83,110 +111,56 @@ bind def } bind def - -/euclidean_length -{ - 1 copy mul exch 1 copy mul add sqrt -} bind def - -% FIXME. translate to middle of box. -% Nice rectangle with rounded corners -/draw_box % breapth width depth height -{ -% currentdict /testing known { - %% real thin lines for testing - /blot 0.005 def -% }{ -% /blot blot-diameter def -% } ifelse - - 0 setlinecap - blot setlinewidth - 1 setlinejoin - - blot 2 div sub /h exch def - blot 2 div sub /d exch def - blot 2 div sub /w exch def - blot 2 div sub /b exch def - - b neg d neg moveto - b w add 0 rlineto - 0 d h add rlineto - b w add neg 0 rlineto - 0 d h add neg rlineto - - currentdict /testing known { - %% outline only, for testing: +/stroke_and_fill { + gsave stroke - }{ - closepath gsave stroke grestore fill - } ifelse + grestore + fill } bind def - -/draw_round_box % breapth width depth height blot +/draw_round_box % x y width height blot { - /blot exch def - + setlinewidth 0 setlinecap - blot setlinewidth 1 setlinejoin - blot 2 div sub /h exch def - blot 2 div sub /d exch def - blot 2 div sub /w exch def - blot 2 div sub /b exch def - - b neg d neg moveto - b w add 0 rlineto - 0 d h add rlineto - b w add neg 0 rlineto - 0 d h add neg rlineto - currentdict /testing known { %% outline only, for testing: - stroke }{ - closepath gsave stroke grestore fill + 4 copy + rectfill } ifelse + rectstroke } bind def -/draw_polygon % x(n) y(n) x(n-1) y(n-1) ... x(1) y(1) n blot fill +/draw_polygon % fill? x(n) y(n) x(n-1) y(n-1) ... x(0) y(0) n blot { - /fillp exch def - /blot exch def + setlinewidth %set to blot 0 setlinecap - blot setlinewidth 1 setlinejoin - /points exch def - 2 copy - moveto - 1 1 points { pop lineto } for + 3 1 roll + moveto % x(0) y(0) + { lineto } repeat % n times closepath - fillp { - gsave stroke grestore fill + { %fill? + stroke_and_fill }{ stroke } ifelse } bind def -/draw_repeat_slash % width slope thick +/draw_repeat_slash % x-width width height { + 2 index % duplicate x-width 1 setlinecap 1 setlinejoin - - /beamthick exch def - /slope exch def - /width exch def - beamthick beamthick slope div euclidean_length - /xwid exch def + 0 0 moveto - xwid 0 rlineto - width slope width mul rlineto - xwid neg 0 rlineto - % width neg width angle sin mul neg rlineto + 0 rlineto % x-width 0 + rlineto % width height + neg 0 rlineto % -x-width 0 closepath fill } bind def @@ -201,27 +175,24 @@ bind def lineto curveto closepath - gsave - fill - grestore - stroke + stroke_and_fill } bind def /draw_dot % x1 y2 R { % 0 360 arc fill stroke - 0 360 arc closepath fill stroke + 0 360 arc closepath stroke_and_fill } bind def -/draw_circle % R T F +/draw_circle % F R T { - /filled exch def setlinewidth dup 0 moveto 0 exch 0 exch 0 360 arc closepath - gsave stroke grestore - filled { fill } if + { stroke_and_fill } + { stroke } + ifelse } bind def @@ -273,19 +244,13 @@ grestore stroke } bind def -/print_letter { - currentpoint - 3 2 roll - glyphshow - moveto -} bind def - /print_glyphs { - -1 1 { - 3 mul -3 roll - print_letter + currentpoint + 3 2 roll + glyphshow + moveto rmoveto - }for + }repeat }bind def %end music-drawing-routines.ps diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index 65fa291944..a2d7fa822a 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -43,9 +43,6 @@ (define (define-font command fontname scaling) (string-append "/" command " { /" fontname " " (ly:number->string scaling) " output-scale div selectfont } bind def\n")) -; (string-append -; "/" command " { /" fontname " findfont " -; (ly:number->string scaling) " output-scale div scalefont } bind def\n")) (define (standard-tex-font? x) (or (equal? (substring x 0 2) "ms") diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 524cdb4ad7..dc20266a01 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -48,6 +48,9 @@ (lily)) ;;; helper functions, not part of output interface +;;; + + (define (escape-parentheses s) (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post)) @@ -102,10 +105,11 @@ (define (circle radius thick fill) (format #f - "~f ~f ~a draw_circle" (round4 radius) (round4 thick) + "~a ~f ~f draw_circle" (if fill - "true " - "false "))) + "true" + "false") + (round4 radius) (round4 thick))) (define (dashed-line thick on off dx dy) (format #f "~a ~a ~a [ ~a ~a ] 0 draw_dashed_line" @@ -143,32 +147,31 @@ cid? w-x-y-named-glyphs) - (format #f "gsave - /~a ~a ~a output-scale div scalefont setfont\n~a grestore" - postscript-font-name - - ;; with normal findfont, GS throws /typecheck for glyphshow. + (define (glyph-spec w x y g) + (let ((prefix (if (string? g) "/" ""))) + (format #f "~f ~f ~a~a" + (round2 (+ w x)) + (round2 y) + prefix g))) + + (format #f (if cid? - " /CIDFont findresource " - " findfont") +"gsave +/~a /CIDFont findresource ~a output-scale div scalefont setfont +~a +~a print_glyphs +grestore" + +"gsave\n/~a ~a output-scale div selectfont +~a +~a print_glyphs +grestore") + postscript-font-name size - (string-append - (apply - string-append - (map (lambda (item) - (let* - ((w (car item)) - (x (cadr item)) - (y (caddr item)) - (g (cadddr item)) - (prefix (if (string? g) "/" ""))) - - (format #f " ~f ~f ~a~a\n" (round2 (+ w x)) - (round2 y) prefix g) - )) - w-x-y-named-glyphs)) - (format #f "~a print_glyphs" (length w-x-y-named-glyphs))) - )) + (string-join (map (lambda (x) (apply glyph-spec x)) + (reverse w-x-y-named-glyphs)) "\n") + (length w-x-y-named-glyphs))) + (define (grob-cause offset grob) (let* ((cause (ly:grob-property grob 'cause)) @@ -208,8 +211,8 @@ (if (string=? (substring key 0 (min (string-length prefix) (string-length key))) prefix) - (string-append "/" key " {" val "} bind def\n") - (string-append "/" key " (" val ") def\n")))) + (format "/~a { ~a } bind def\n" key val) + (format "/~a (~a) def\n" key val)))) (define (named-glyph font glyph) (format #f "~a /~a glyphshow " ;;Why is there a space at the end? @@ -226,28 +229,38 @@ ~a grestore\n" - (str4 x) - (str4 y) - s)) + (str4 x) + (str4 y) + s)) (define (polygon points blot-diameter filled?) (format #f "~a ~a ~a ~a draw_polygon" + (if filled? "true" "false") (numbers->string4 points) - (str4 (/ (length points) 2)) - (str4 blot-diameter) - (if filled? "true" "false"))) + (number->string (- (/ (length points) 2) 1)) + (str4 blot-diameter))) + +(define (repeat-slash width slope beam-thickness) + (define (euclidean-length x y) + (sqrt (+ (* x x) (* y y)))) -(define (repeat-slash wid slope thick) - (format #f "~a draw_repeat_slash" - (numbers->string4 (list wid slope thick)))) + (let ((x-width (euclidean-length slope (/ beam-thickness slope))) + (height (* width slope))) + (format #f "~a draw_repeat_slash" + (numbers->string4 (list x-width width height))))) ;; restore color from stack (define (resetcolor) "setrgbcolor\n") -(define (round-filled-box x y width height blotdiam) - (format #f "~a draw_round_box" - (numbers->string4 - (list x y width height blotdiam)))) +(define (round-filled-box left right bottom top blotdiam) + (let* ((halfblot (/ blotdiam 2)) + (x (- halfblot left)) + (width (- right (+ halfblot x))) + (y (- halfblot bottom)) + (height (- top (+ halfblot y)))) + (format #f "~a draw_round_box" + (numbers->string4 + (list x y width height blotdiam))))) ;; save current color on stack and set new color (define (setcolor r g b) @@ -260,6 +273,7 @@ grestore\n" (let* ((space-length (cdar (ly:text-dimension font " "))) (space-move (string-append (number->string space-length) + ;; how much precision do we need here? " 0.0 rmoveto ")) (out-vec (decode-byte-string s))) -- 2.39.2