* lily/lookup.cc (slur): Invoke bezier-bow.

[lilypond.git] / scm / ps.scm

diff --git a/scm/ps.scm b/scm/ps.scm
index f469ec7ac9a308679542ac94ac1e7955e5e0f90b..b0f1bdb41d9275a2324275d24558913c63fcbea4 100644 (file)
--- a/scm/ps.scm
+++ b/scm/ps.scm
@@ -8,20 +8,25 @@
 
 
 (define-module (scm ps)
-  :export (ps-output-expression)
-  :no-backtrace
   )
 
 (define this-module (current-module))
 
-(define (ps-output-expression expr port)
-  (display (eval expr this-module) port)
-  )
+(debug-enable 'backtrace)
+
+(if (or (equal? (minor-version) "4.1")
+       (equal? (minor-version) "4")
+       (equal? (minor-version) "3.4"))
+    (define-public (ps-output-expression expr port)
+      (display (eval-in-module expr this-module) port))
+
+    (define-public (ps-output-expression expr port)
+      (display (eval expr this-module) port)))
 
  
 (use-modules
  (guile)
- (guile-user))
+)
 
 
 
@@ -86,12 +91,19 @@
   (string-append
    "/" command
    " { /"
-   (car name-mag)
+   (capitalize-font-name (car name-mag))
    " findfont "
-   "12 " (ly-number->string (cdr name-mag)) " mul "
-   "lilypondpaperoutputscale div scalefont setfont } bind def "
+   "20 " (ly-number->string (cdr name-mag)) " mul "
+   "output-scale div scalefont setfont } bind def "
    "\n"))
 
+;; Ugh, the Bluesky type1 fonts for computer modern use capitalized 
+;; postscript font names.
+(define (capitalize-font-name name)
+  (if (equal? (substring name 0 2) "cm")
+      (string-upcase name)
+      name))
+
 (define (beam width slope thick)
   (string-append
    (numbers->string (list slope width thick)) " draw_beam" ))
@@ -107,10 +119,6 @@
   (invoke-char " show" i))
 
 
-(define (hairpin thick width starth endh )
-  (string-append 
-   (numbers->string (list width starth endh thick))
-   " draw_hairpin"))
 
 ;; what the heck is this interface ?
 (define (dashed-slur thick dash l)
@@ -129,13 +137,31 @@
    " "
    (ly-number->string dy)
    " "
-   (ly-number->string thick) 
+   (ly-number->string thick)
    " [ "
    (ly-number->string on)
    " "
    (ly-number->string off)
    " ] 0 draw_dashed_line"))
 
+(define (draw-line thick x1 y1 x2 y2)
+
+  (string-append 
+  "    1 setlinecap
+       1 setlinejoin "
+  (ly-number->string thick)
+       " setlinewidth "
+   (ly-number->string x1)
+   " "
+   (ly-number->string y1)
+   " moveto "
+   (ly-number->string x2)
+   " "
+   (ly-number->string y2)
+   " lineto stroke"
+
+  ))
+
 (define (repeat-slash wid slope thick)
   (string-append (numbers->string (list wid slope thick))
                 " draw_repeat_slash"))
@@ -149,6 +175,16 @@
   (string-append (numbers->string (list breapth width depth height))
                 " draw_box" ))
 
+(define (roundfilledbox x width y height blotdiam)
+   (string-append " "
+      (numbers->string
+         (list x width y height blotdiam)) " draw_round_box"))
+
+(define (dot x y radius)
+    (string-append " "
+     (numbers->string
+      (list x y radius)) " draw_dot"))
+
 ;; obsolete?
 (define (font-def i s)
   (string-append
@@ -166,7 +202,9 @@
    " {exch pop //systemdict /run get exec} "
    (ly-gulp-file "music-drawing-routines.ps")
    "{ exch pop //systemdict /run get exec } "
+;; ps-testing is broken: global module
    (if (defined? 'ps-testing) "\n /testing true def" "")
+;;   "\n /testing true def"
    ))
 
 (define (lily-def key val)
@@ -186,54 +224,66 @@
   (string-append 
    "(\\" (inexact->string i 8) ") " s " " ))
 
-(define (invoke-dim1 s d) 
-  (string-append
-   (ly-number->string (* d  (/ 72.27 72))) " " s ))
 
 (define (placebox x y s) 
   (string-append 
    (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 
+;; two beziers
 (define (bezier-sandwich l thick)
   (string-append 
    (apply string-append (map control->string l))
-   (ly-number->string  thick)
-   " draw_bezier_sandwich"))
+   (ly-number->string thick)
+   " draw_bezier_sandwich "))
+
+;; two beziers with round endings
+(define (bezier-bow l thick)
+  (string-append 
+   (apply string-append (map control->string l))
+   (ly-number->string thick)
+   " draw_bezier_sandwich "
+   (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))))
+
+;; two beziers with round endings
+(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)))
+    (string-append " "
+     (numbers->string
+      (list x0 y0
+           (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
+     " draw_dot")))
 
                                        ; TODO: use HEIGHT argument
-(define (start-line height)
+
+  (define (start-system height)
   (string-append
    "\n"
    (ly-number->string height)
-   " start-line {
-lilypondpaperoutputscale lilypondpaperoutputscale scale
+   " start-system {
+set-ps-scale-to-lily-scale
+
 "))
 
 (define (stem breapth width depth height) 
   (string-append (numbers->string (list breapth width depth height))
                 " draw_box" ))
 
-(define (stop-line)
-  "}\nstop-line\n")
+(define (stop-system)
+  "}\nstop-system\n")
 
-(define (stop-last-line)
-  "}\nstop-line\n")
+(define (stop-last-system)
+  "}\nstop-system\n")
 
 (define (text s)
   (string-append "(" s ") show  "))
 
 
-(define (volta h w thick vert_start vert_end)
-  (string-append 
-   (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
-   " draw_volta"))
-
-(define (tuplet ht gap dx dy thick dir)
-  (string-append 
-   (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
-   " draw_tuplet"))
-
-
 (define (unknown) 
   "\n unknown\n")