X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fpdf.scm;h=07c5b145f07f4691cb543d54ef9018105a8e7318;hb=67158e4f7f55d9b6ecf965f2de2817dde3b10261;hp=a47e67f4f88d4a70ff21e93e9a0ba9a1f1446f93;hpb=f7f4d9dcd37086b5c8b417719a0fcc924aceef92;p=lilypond.git

diff --git a/scm/pdf.scm b/scm/pdf.scm
index a47e67f4f8..07c5b145f0 100644
--- a/scm/pdf.scm
+++ b/scm/pdf.scm
@@ -4,307 +4,269 @@
 ;;; 
 ;;; (c) 2001 Stephen Peters <portnoy@portnoy.org>
 
-; currently no font commands; this is a helper for pdftex.scm.
-
-(define (pdf-scm action-name)
-  ; simple commands to store and update currentpoint.  This makes the
-  ; other procedures simple rewrites of the PostScript code.
-  (define currentpoint (cons 0 0))
-  (define (showcp) 
-    (string-append (ly-number->string (car currentpoint)) " " 
-		   (ly-number->string (cdr currentpoint)) " "))
-  (define (moveto x y)
-    (set! currentpoint (cons x y))
-    (string-append (showcp) "m "))
-  (define (moveto-pair pair)
-    (moveto (car pair) (cdr pair)))
-  (define (rmoveto x y)
-    (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
-  (define (lineto x y)
-    (set! currentpoint (cons x y))
-    (string-append (showcp) "l "))
-  (define (lineto-pair pair)
-    (lineto (car pair) (cdr pair)))
-  (define (rlineto x y)
-    (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
-  (define (curveto x1 y1 x2 y2 x y)
-    (set! currentpoint (cons x y))
-    (string-append (ly-number->string x1) (ly-number->string y1)
-		   (ly-number->string x2) (ly-number->string y2)
-		   (ly-number->string x) (ly-number->string y) "c "))
-  (define (curveto-pairs pt1 pt2 pt)
-    (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
-  (define (closefill) "h f ")
-  (define (closestroke) "S ")
-  (define (setlinewidth w) (string-append (ly-number->string w) "w "))
-  (define (setgray g) (string-append (ly-number->string g) "g "))
-  (define (setlineparams) "1 j 1 J ")
-  
-  (define (beam width slope thick)
-    (let ((ht (* slope width)))
-      (string-append (moveto 0 (- (/ thick 2)))
-		     (rlineto width ht)
-		     (rlineto 0 thick)
-		     (lineto 0 (/ thick 2))
-		     (closefill))))
-
-  (define (comment s) 
-    (string-append "% " s "\n"))
-
-  (define (brack-traject pair ds alpha)
-    (let ((alpha-rad (* alpha (/ 3.141592654 180))))
-      (cons (+ (car pair) (* (cos alpha-rad) ds))
-	    (+ (cdr pair) (* (sin alpha-rad) ds)))))
-    
-  (define (bracket arch_angle arch_width arch_height height arch_thick thick)
-    (let* ((halfht (+ (/ height 2) thick))
-	   (farpt (cons (+ thick arch_height) 
-			(+ (- halfht arch_thick) arch_width)))
-	   (halfbrack 
-	    (string-append (moveto 0 0)
-			   (lineto thick 0)
-			   (lineto thick (- halfht arch_thick))
-			   (curveto-pairs
-			    (brack-traject (cons thick 
-						 (- halfht arch_thick))
-					   (* 0.4 arch_height) 0)
-			    (brack-traject farpt 
-					   (* -0.25 arch_height) 
-					   arch_angle)
-			    farpt)
-			   (curveto-pairs 
-			    (brack-traject farpt
-					   (* -0.15 arch_height)
-					   arch_angle)
-			    (brack-traject (cons (/ thick 2) halfht)
-					   (/ arch_height 2) 0)
-			    (cons 0 halfht))
-			   (lineto 0 0)
-			   (closefill))))
-      (string-append (setlinewidth (/ thick 2))
-		     (setlineparams)
-		     "q 1 0 0 -1 0 0 cm " ; flip coords
-		     halfbrack
-		     "Q " ; grestore
-		     halfbrack)))
-  
-  (define (char i)
-    (invoke-char " show" i))
-
-  (define (hairpin thick width starth endh )
-    (string-append (setlinewidth thick)
-		   (moveto 0 starth)
-		   (lineto width endh)
-		   (moveto 0 (- starth))
-		   (lineto width (- endh))
-		   (closestroke)))
-
-  (define (dashed-slur thick dash l)
-    (string-append (setlineparams)
-		   "[ " (ly-number->string dash) " "
-		   (ly-number->string (* 10 thick)) " ] 0 d "
-		   (setlinewidth thick)
-		   (moveto-pair (car l))
-		   (apply curveto (cdr l))
-		   (closestroke)))
-		   
-  (define (dashed-line thick on off dx dy)
-    (string-append (setlineparams)
-		   "[ " (ly-number->string on) " "
-		   (ly-number->string off) " ] 0 d "
-		   (setlinewidth thick)
-		   (moveto 0 0)
-		   (lineto dx dy)
-		   (closestroke)))
-
-  (define (repeat-slash width slope beamthick)
-    (let* ((height (/ beamthick slope))
-	   (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
-      (string-append (moveto 0 0)
-		     (rlineto xwid 0)
-		     (rlineto width (* slope width))
-		     (rlineto (- xwid) 0)
-		     (closefill))))
-
-  (define (end-output) "")
-  
-  (define (experimental-on) "")
-  
-  (define (filledbox breadth width depth height) 
-    (string-append (ly-number->string (- breadth))
-		   (ly-number->string (- depth))
-		   (ly-number->string (+ breadth width))
-		   (ly-number->string (+ depth height))
-		   " re f "))
-
-;; TODO:
-;;
-;;(define (dot x y diam)
-;;  (let (radius (/ diam 2))
-;;    (string-append (ly-number->string (x))
-;;		     (ly-number->string (y))
-;;		     (ly-number->string (radius))
-;;		     " ??? "))) ;; how to draw a circle in PDF?
-;;
-;;(define (roundfilledbox x width y height blotdiam)
-;;  (string-append " "
-;;    (dot x y blotdiam)
-;;    (dot (+ x width) y blotdiam)
-;;    (dot (+ x width) (+ y height) blotdiam)
-;;    (dot x (+ y height) blotdiam)
-;;    (filledbox (+ x (/ blotdiam 2)) (+ width (/ blotdiam 2)) y height)
-;;    (filledbox x width (+ y (/ blotdiam 2)) (+ height (/ blotdiam 2)))))
-;;
-;;
-;; WORKAROUND:
-;;
-  (define (roundfilledbox breadth width depth height) 
-    (filledbox breadth width depth height))
-;;
-
-  (define (font-def i s) "")
-
-  (define (font-switch i) "")
-
-  (define (header-end) "")
-  
-  (define (lily-def key val) "")
-
-  (define (header creator generate) "")
-  
-  (define (invoke-char s i)
-    (string-append 
-     "(\\" (inexact->string i 8) ") " s " " ))
-  
-  (define (placebox x y s) "")
-
-  (define (bezier-sandwich l thick)
-    (string-append (setlinewidth thick)
-		   (moveto-pair (list-ref l 7))
-		   (curveto-pairs (list-ref l 4)
-				  (list-ref l 5)
-				  (list-ref l 6))
-		   (lineto-pair (list-ref l 3))
-		   (curveto-pairs (list-ref l 0)
-				  (list-ref l 1)
-				  (list-ref l 2))
-		   "B "))
-
-  (define (start-line height) "")
-  
-  (define (stem breadth width depth height) 
-    (filledbox breadth width depth height))
-
-  (define (stop-line) "")
-
-  (define (text s) "")
-
-  (define (volta h w thick vert_start vert_end)
-    (string-append (setlinewidth thick)
-		   (setlineparams)
-		   (if (= vert_start 0) 
-		       (string-append (moveto 0 0)
-				      (lineto 0 h))
-		       (moveto 0 h))
-		   (lineto w h)
-		   (if (= vert_end 0) (lineto w 0) "")
-		   (closestroke)))
-
-  (define (tuplet ht gap dx dy thick dir)
-    (let ((gapy (* (/ dy dx) gap)))
-      (string-append (setlinewidth thick)
-		     (setlineparams)
-		     (moveto 0 (- (* ht dir)))
-		     (lineto 0 0)
-		     (lineto (/ (- dx gap) 2)
-			     (/ (- dy gapy) 2))
-		     (moveto (/ (+ dx gap) 2)
-			     (/ (+ dy gapy) 2))
-		     (lineto dx dy)
-		     (lineto dx (- dy (* ht dir)))
-		     (closestroke))))
-
-  (define (unknown) "\n unknown\n")
-
-  ; Problem here -- we're using /F18 for the font, but we don't know
-  ; for sure that that will exist.
-  (define (ez-ball ch letter-col ball-col)
-    (let ((origin (cons 0.45 0)))
-      (string-append (setgray 0)
-		     (setlinewidth 1.1)
-		     (moveto-pair origin) (lineto-pair origin)
-		     (closestroke)
-		     (setgray ball-col)
-		     (setlinewidth 0.9)
-		     (moveto-pair origin) (lineto-pair origin)
-		     (closestroke)
-		     (setgray letter-col)
-		     (moveto-pair origin)
-		     "BT "
-		     "/F18 0.85 Tf "
-		     "-0.28 -0.30 Td " ; move for text block
-		     "[(" ch ")] TJ ET ")))
-
-  (define (define-origin a b c ) "")
-  (define (no-origin) "")
-  
-  ;; PS
-  (cond ((eq? action-name 'all-definitions)
-	 `(begin
-	    (define beam ,beam)
-	    (define tuplet ,tuplet)
-	    (define bracket ,bracket)
-	    (define char ,char)
-	    (define volta ,volta)
-	    (define bezier-sandwich ,bezier-sandwich)
-	    (define dashed-line ,dashed-line) 
-	    (define dashed-slur ,dashed-slur) 
-	    (define hairpin ,hairpin) 
-	    (define end-output ,end-output)
-	    (define experimental-on ,experimental-on)
-	    (define filledbox ,filledbox)
-	    (define roundfilledbox ,roundfilledbox)
-	    (define font-def ,font-def)
-	    (define font-switch ,font-switch)
-	    (define header-end ,header-end)
-	    (define lily-def ,lily-def)
-	    (define font-load-command ,font-load-command)
-	    (define header ,header) 
-	    (define invoke-char ,invoke-char) 
-
-	    (define placebox ,placebox)
-	    (define repeat-slash ,repeat-slash) 
-	    (define select-font ,select-font)
-	    (define start-line ,start-line)
-	    (define stem ,stem)
-	    (define stop-line ,stop-line)
-	    (define stop-last-line ,stop-line)
-	    (define text ,text)
-	    (define no-origin ,no-origin)
-	    (define define-origin ,define-origin)
-	    (define ez-ball ,ez-ball)
-	    ))
-	((eq? action-name 'tuplet) tuplet)
-	((eq? action-name 'beam) beam)
-	((eq? action-name 'bezier-sandwich) bezier-sandwich)
-	((eq? action-name 'bracket) bracket)
-	((eq? action-name 'char) char)
-	((eq? action-name 'dashed-line) dashed-line) 
-	((eq? action-name 'dashed-slur) dashed-slur) 
-	((eq? action-name 'hairpin) hairpin)
-	((eq? action-name 'experimental-on) experimental-on)
-	((eq? action-name 'ez-ball) ez-ball)	
-	((eq? action-name 'filledbox) filledbox)
-	((eq? action-name 'roundfilledbox) roundfilledbox)
-	((eq? action-name 'repeat-slash) repeat-slash)
-	((eq? action-name 'select-font) select-font)
-	((eq? action-name 'volta) volta)
-	(else (error "unknown tag -- PDF-SCM " action-name))
-	)
+
+;currently no font commands; this is a helper for pdftex.scm.
+
+(define-module (scm pdf)
   )
 
-(define (scm-pdf-output)
-  (primitive-eval (pdf-scm 'all-definitions)))
+
+(define this-module (current-module))
+
+(use-modules
+ (guile)
+ )
+
+
+
+; simple commands to store and update currentpoint.  This makes the
+; other procedures simple rewrites of the PostScript code.
+
+(define currentpoint (cons 0 0))
+(define (showcp) 
+  (string-append (number-pair->string currentpoint) " "))
+(define (moveto x y)
+  (set! currentpoint (cons x y))
+  (string-append (showcp) "m "))
+(define (moveto-pair pair)
+  (moveto (car pair) (cdr pair)))
+(define (rmoveto x y)
+  (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
+(define (lineto x y)
+  (set! currentpoint (cons x y))
+  (string-append (showcp) "l "))
+(define (lineto-pair pair)
+  (lineto (car pair) (cdr pair)))
+(define (rlineto x y)
+  (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
+(define (curveto x1 y1 x2 y2 x y)
+  (set! currentpoint (cons x y))
+  (string-append (ly:number->string x1) (ly:number->string y1)
+		 (ly:number->string x2) (ly:number->string y2)
+		 (ly:number->string x) (ly:number->string y) "c "))
+(define (curveto-pairs pt1 pt2 pt)
+  (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
+(define (closefill) "h f ")
+(define (closestroke) "S ")
+(define (setlinewidth w) (string-append (ly:number->string w) "w "))
+(define (setgray g) (string-append (ly:number->string g) "g "))
+(define (setlineparams) "1 j 1 J ")
+
+(define (beam width slope thick)
+  (let ((ht (* slope width)))
+    (string-append (moveto 0 (- (/ thick 2)))
+		   (rlineto width ht)
+		   (rlineto 0 thick)
+		   (lineto 0 (/ thick 2))
+		   (closefill))))
+
+(define (comment s) 
+  (string-append "% " s "\n"))
+
+(define (brack-traject pair ds alpha)
+  (let ((alpha-rad (* alpha (/ 3.141592654 180))))
+    (cons (+ (car pair) (* (cos alpha-rad) ds))
+	  (+ (cdr pair) (* (sin alpha-rad) ds)))))
+
+(define (bracket arch_angle arch_width arch_height height arch_thick thick)
+  (let* ((halfht (+ (/ height 2) thick))
+	 (farpt (cons (+ thick arch_height) 
+		      (+ (- halfht arch_thick) arch_width)))
+	 (halfbrack 
+	  (string-append (moveto 0 0)
+			 (lineto thick 0)
+			 (lineto thick (- halfht arch_thick))
+			 (curveto-pairs
+			  (brack-traject (cons thick 
+					       (- halfht arch_thick))
+					 (* 0.4 arch_height) 0)
+			  (brack-traject farpt 
+					 (* -0.25 arch_height) 
+					 arch_angle)
+			  farpt)
+			 (curveto-pairs 
+			  (brack-traject farpt
+					 (* -0.15 arch_height)
+					 arch_angle)
+			  (brack-traject (cons (/ thick 2) halfht)
+					 (/ arch_height 2) 0)
+			  (cons 0 halfht))
+			 (lineto 0 0)
+			 (closefill))))
+    (string-append (setlinewidth (/ thick 2))
+		   (setlineparams)
+		   "q 1 0 0 -1 0 0 cm " ; flip coords
+		   halfbrack
+		   "Q " ; grestore
+		   halfbrack)))
+
+(define (char i)
+  (invoke-char " show" i))
+
+
+(define (dashed-slur thick dash l)
+  (string-append (setlineparams)
+		 "[ " (ly:number->string dash) " "
+		 (ly:number->string (* 10 thick)) " ] 0 d "
+		 (setlinewidth thick)
+		 (moveto-pair (car l))
+		 (apply curveto (cdr l))
+		 (closestroke)))
+
+(define (dashed-line thick on off dx dy)
+  (string-append (setlineparams)
+		 "[ " (ly:number->string on) " "
+		 (ly:number->string off) " ] 0 d "
+		 (setlinewidth thick)
+		 (moveto 0 0)
+		 (lineto dx dy)
+		 (closestroke)))
+
+(define (repeat-slash width slope beamthick)
+  (let* ((height (/ beamthick slope))
+	 (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
+    (string-append (moveto 0 0)
+		   (rlineto xwid 0)
+		   (rlineto width (* slope width))
+		   (rlineto (- xwid) 0)
+		   (closefill))))
+
+(define (end-output) "")
+
+(define (experimental-on) "")
+
+(define (filledbox breadth width depth height) 
+  (string-append (ly:number->string (- breadth))
+		 (ly:number->string (- depth))
+		 (ly:number->string (+ breadth width))
+		 (ly:number->string (+ depth height))
+		 " re f "))
+
+(define (roundfilledbox breadth width depth height blotdiam)
+  (let* ((rad (/ blotdiam 2))
+ 	 (h (- height rad))
+ 	 (d (- depth rad))
+ 	 (w (- width rad))
+ 	 (b (- breadth rad)))
+    (string-append " 0 J "
+ 		   (setlinewidth blotdiam)
+ 		   "1 j "
+ 		   (moveto (- b) (- d))
+ 		   (rlineto (+ b w) 0)
+ 		   (rlineto 0 (+ d h))
+ 		   (rlineto (- (+ b w)) 0)
+ 		   (rlineto 0 (- (+ d h)))
+ 		   "b ")))
+
+;; PDF doesn't have the nifty arc operator.  This uses a fast
+;; approximation with two curves.  It bulges out a bit more than a
+;; true circle should along the 45 degree axes, but most users won't
+;; notice.
+(define (dot x y radius)
+  (string-append (moveto (- x radius) y)
+ 		 (curveto (- x radius) (+ y (* 1.3333 radius))
+ 			  (+ x radius) (+ y (* 1.3333 radius))
+ 			  (+ x radius) y)
+ 		 (curveto (+ x radius) (- y (* 1.3333 radius))
+ 			  (- x radius) (- y (* 1.3333 radius))
+ 			  (- x radius) y)
+ 		 "f "))
+
+
+(define (roundfilledbox breadth width depth height blot) 
+  (filledbox breadth width depth height))
+
+(define (font-def i s) "")
+
+(define (font-switch i) "")
+
+(define (header-end) "")
+
+(define (lily-def key val) "")
+
+(define (header creator generate) "")
+
+(define (invoke-char s i)
+  (string-append 
+   "(\\" (inexact->string i 8) ") " s " " ))
+
+(define (placebox x y s) "")
+
+(define (bezier-bow l thick)
+  (bezier-sandwich l thick))
+
+(define (bezier-sandwich l thick)
+  (string-append (setlinewidth thick)
+		 (moveto-pair (list-ref l 7))
+		 (curveto-pairs (list-ref l 4)
+				(list-ref l 5)
+				(list-ref l 6))
+		 (lineto-pair (list-ref l 3))
+		 (curveto-pairs (list-ref l 0)
+				(list-ref l 1)
+				(list-ref l 2))
+		 "B "
+		 (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
+		 (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
+
+(define (bezier-ending z0 z1 z2)
+  (let ((x0 (car z0))
+	(y0 (cdr z0))
+	(x1 (car z1))
+	(y1 (cdr z1))
+	(x2 (car z2))
+	(y2 (cdr z2)))
+    (dot x0 y0 
+	 (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) 
+		     (* (- y1 y2) (- y1 y2)))) 2))))
+
+
+(define (start-system width height) "")
+
+(define (stem breadth width depth height) 
+  (filledbox breadth width depth height))
+
+(define (stop-system) "")
+
+(define (text s) "")
+
+(define (polygon points blotdiameter) "") ;; TODO
+
+(define (draw-line thick fx fy tx ty)
+  (string-append (setlineparams)
+		 (setlinewidth thick)
+		 (moveto fx fy)
+		 (lineto tx ty)
+		 "S "))
+
+(define (unknown) "\n unknown\n")
+
+; Problem here -- we're using /F18 for the font, but we don't know 
+; for sure that that will exist.
+
+(define (ez-ball ch letter-col ball-col)
+  (let ((origin (cons 0.45 0)))
+    (string-append (setgray 0)
+		   (setlinewidth 1.1)
+		   (moveto-pair origin) (lineto-pair origin)
+		   (closestroke)
+		   (setgray ball-col)
+		   (setlinewidth 0.9)
+		   (moveto-pair origin) (lineto-pair origin)
+		   (closestroke)
+		   (setgray letter-col)
+		   (moveto-pair origin)
+		   "BT "
+		   "/F18 0.85 Tf "
+		   "-0.28 -0.30 Td " ; move for text block
+		   "[(" ch ")] TJ ET ")))
+
+(define (define-origin a b c ) "")
+(define (no-origin) "")
+
+(define-public (pdf-output-expression expr port)
+  (display (eval expr this-module) port) )
+
 
 ; Local Variables:
 ; scheme-program-name: "guile"